diff --git a/assets/ohyes.png b/assets/ohyes.png new file mode 100644 Binary files /dev/null and b/assets/ohyes.png differ diff --git a/docs/c-api.rst b/docs/c-api.rst --- a/docs/c-api.rst +++ b/docs/c-api.rst @@ -23,7 +23,7 @@ Context creation is parameterised by a configuration object. Any changes to the configuration must be made *before* calling :c:func:`futhark_context_new`. A configuration object must not be -freed while before any context objects for which it is used. The same +freed before any context objects for which it is used. The same configuration may be used for multiple concurrent contexts. .. c:type:: struct futhark_context_config diff --git a/docs/conf.py b/docs/conf.py --- a/docs/conf.py +++ b/docs/conf.py @@ -65,7 +65,7 @@ # Get cabal file cabal_file = open('../futhark.cabal', 'r').read() # Extract version - return re.search('version:[ ]*([^ ]*)', cabal_file).group(1) + return re.search(r'^version:[ ]*([^ ]*)$', cabal_file, flags=re.MULTILINE).group(1) version = get_version() # The full version, including alpha/beta/rc tags. diff --git a/docs/hacking.rst b/docs/hacking.rst --- a/docs/hacking.rst +++ b/docs/hacking.rst @@ -4,18 +4,22 @@ =============================== The Futhark compiler is a significant body of code with a not entirely -straightforward design. The main reference is the `documentation of -the compiler internals`_ that is automatically generated by Haddock. -If you feel that it is incomplete, or lacks an explanation, then feel -free to report it as an issue on the `GitHub page`_. Documentation -bugs are bugs too. +straightforward design. The main source of documentation is the +Haddock comments in the source code itself. You can generate +hyperlinked reference documentation by running ``stack haddock`` or +``cabal haddock``, depending on your preference of build system. +There is also possibly-outdated `documentation on Hackage`_ -.. _`documentation of the compiler internals`: https://futhark-lang.org/haddock/ +If you feel that the documentation is incomplete, or something lacks +an explanation, then feel free to report it as an issue on the `GitHub +page`_. Documentation bugs are bugs too. + +.. _`documentation on Hackage`: http://hackage.haskell.org/package/futhark .. _`GitHub page`: https://github.com/diku-dk/futhark -The Futhark compiler is built using `Stack`_. It's a good idea to -familiarise yourself with how it works. As a starting point, here are -a few hints: +The Futhark compiler is usually built using `Stack`_. It's a good +idea to familiarise yourself with how it works. As a starting point, +here are a few hints: * When testing, pass ``--fast`` to ``stack`` to disable the GHC optimiser. This speeds up builds considerably (although it still diff --git a/docs/language-reference.rst b/docs/language-reference.rst --- a/docs/language-reference.rst +++ b/docs/language-reference.rst @@ -14,8 +14,8 @@ practice (for example by applying rules of operator precedence). This reference describes only the language itself. Documentation for -the basis library is `available elsewhere -`_. +the built-in prelude is `available elsewhere +`_. Identifiers and Keywords ------------------------ @@ -436,6 +436,7 @@ : | "let" `id` `type_param`* `pat`+ [":" `type`] "=" `exp` "in" `exp` : | "(" "\" `pat`+ [":" `type`] "->" `exp` ")" : | "loop" `pat` [("=" `exp`)] `loopform` "do" `exp` + : | "#[" attr "]" `exp` : | "unsafe" `exp` : | "assert" `atom` `atom` : | `exp` "with" "[" `index` ("," `index`)* "]" "=" `exp` @@ -798,6 +799,13 @@ Numerical negation of ``x``, which must be of numeric type. +``#[attr] e`` +............. + +Apply the given attribute to the expression. Attributes are an ad-hoc +and optional mechanism for providing extra information, directives, or +hints to the compiler. See :ref:`attributes` for more information. + ``unsafe e`` ............ @@ -808,6 +816,8 @@ the code is correct; eliding such checks can lead to memory corruption. +This construct is deprecated. Use the ``#[unsafe]`` attribute instead. + ``assert cond e`` ................. @@ -882,7 +892,7 @@ Equivalent to ``loop (pat = initial) for x in [0..1... + Regarding the internal design of the compiler, the following modules make + good starting points: + . + * "Futhark.IR.Syntax" explains the + basic design of the intermediate representation (IR). + * "Futhark.Construct" explains how to write code that + manipulates and creates AST fragments. + . + <> + category: Language homepage: https://futhark-lang.org bug-reports: https://github.com/diku-dk/futhark/issues @@ -29,6 +44,8 @@ docs/Makefile docs/conf.py docs/requirements.txt +extra-doc-files: + assets/*.png source-repository head type: git @@ -41,8 +58,8 @@ Futhark.Analysis.Alias Futhark.Analysis.CallGraph Futhark.Analysis.DataDependencies - Futhark.Analysis.HORepresentation.MapNest - Futhark.Analysis.HORepresentation.SOAC + Futhark.Analysis.HORep.MapNest + Futhark.Analysis.HORep.SOAC Futhark.Analysis.Metrics Futhark.Analysis.PrimExp Futhark.Analysis.PrimExp.Convert @@ -52,7 +69,6 @@ Futhark.Analysis.Rephrase Futhark.Analysis.ScalExp Futhark.Analysis.SymbolTable - Futhark.Analysis.Usage Futhark.Analysis.UsageTable Futhark.Bench Futhark.Binder @@ -60,10 +76,10 @@ Futhark.CLI.Autotune Futhark.CLI.Bench Futhark.CLI.C - Futhark.CLI.Check - Futhark.CLI.CSharp Futhark.CLI.CSOpenCL + Futhark.CLI.CSharp Futhark.CLI.CUDA + Futhark.CLI.Check Futhark.CLI.Datacmp Futhark.CLI.Dataset Futhark.CLI.Dev @@ -98,7 +114,7 @@ Futhark.CodeGen.Backends.SequentialC Futhark.CodeGen.Backends.SequentialCSharp Futhark.CodeGen.Backends.SequentialPython - Futhark.CodeGen.Backends.SimpleRepresentation + Futhark.CodeGen.Backends.SimpleRep Futhark.CodeGen.ImpCode Futhark.CodeGen.ImpCode.Kernels Futhark.CodeGen.ImpCode.OpenCL @@ -122,9 +138,43 @@ Futhark.Compiler.Program Futhark.Construct Futhark.Doc.Generator - Futhark.Doc.Html Futhark.Error Futhark.FreshNames + Futhark.IR + Futhark.IR.Aliases + Futhark.IR.Decorations + Futhark.IR.Kernels + Futhark.IR.Kernels.Kernel + Futhark.IR.Kernels.Simplify + Futhark.IR.Kernels.Sizes + Futhark.IR.KernelsMem + Futhark.IR.Mem + Futhark.IR.Mem.IxFun + Futhark.IR.Mem.Simplify + Futhark.IR.Pretty + Futhark.IR.Primitive + Futhark.IR.Prop + Futhark.IR.Prop.Aliases + Futhark.IR.Prop.Constants + Futhark.IR.Prop.Names + Futhark.IR.Prop.Patterns + Futhark.IR.Prop.Ranges + Futhark.IR.Prop.Rearrange + Futhark.IR.Prop.Reshape + Futhark.IR.Prop.Scope + Futhark.IR.Prop.TypeOf + Futhark.IR.Prop.Types + Futhark.IR.Ranges + Futhark.IR.RetType + Futhark.IR.SOACS + Futhark.IR.SOACS.SOAC + Futhark.IR.SOACS.Simplify + Futhark.IR.SegOp + Futhark.IR.Seq + Futhark.IR.SeqMem + Futhark.IR.Syntax + Futhark.IR.Syntax.Core + Futhark.IR.Traversals Futhark.Internalise Futhark.Internalise.AccurateSizes Futhark.Internalise.Bindings @@ -140,10 +190,10 @@ Futhark.Optimise.Fusion Futhark.Optimise.Fusion.Composing Futhark.Optimise.Fusion.LoopKernel - Futhark.Optimise.InliningDeadFun Futhark.Optimise.InPlaceLowering Futhark.Optimise.InPlaceLowering.LowerIntoStm Futhark.Optimise.InPlaceLowering.SubstituteIndices + Futhark.Optimise.InliningDeadFun Futhark.Optimise.Simplify Futhark.Optimise.Simplify.ClosedForm Futhark.Optimise.Simplify.Engine @@ -163,9 +213,9 @@ Futhark.Pass.ExtractKernels.BlockedKernel Futhark.Pass.ExtractKernels.DistributeNests Futhark.Pass.ExtractKernels.Distribution + Futhark.Pass.ExtractKernels.ISRWIM Futhark.Pass.ExtractKernels.Interchange Futhark.Pass.ExtractKernels.Intragroup - Futhark.Pass.ExtractKernels.ISRWIM Futhark.Pass.ExtractKernels.StreamKernel Futhark.Pass.ExtractKernels.ToKernels Futhark.Pass.FirstOrderTransform @@ -177,41 +227,6 @@ Futhark.Pkg.Info Futhark.Pkg.Solve Futhark.Pkg.Types - Futhark.Representation.Aliases - Futhark.Representation.AST - Futhark.Representation.AST.Annotations - Futhark.Representation.AST.Attributes - Futhark.Representation.AST.Attributes.Aliases - Futhark.Representation.AST.Attributes.Constants - Futhark.Representation.AST.Attributes.Names - Futhark.Representation.AST.Attributes.Patterns - Futhark.Representation.AST.Attributes.Ranges - Futhark.Representation.AST.Attributes.Rearrange - Futhark.Representation.AST.Attributes.Reshape - Futhark.Representation.AST.Attributes.Scope - Futhark.Representation.AST.Attributes.TypeOf - Futhark.Representation.AST.Attributes.Types - Futhark.Representation.AST.Pretty - Futhark.Representation.AST.RetType - Futhark.Representation.AST.Syntax - Futhark.Representation.AST.Syntax.Core - Futhark.Representation.AST.Traversals - Futhark.Representation.Mem - Futhark.Representation.Mem.IxFun - Futhark.Representation.Mem.Simplify - Futhark.Representation.Kernels - Futhark.Representation.Kernels.Kernel - Futhark.Representation.Kernels.Simplify - Futhark.Representation.Kernels.Sizes - Futhark.Representation.KernelsMem - Futhark.Representation.Primitive - Futhark.Representation.Ranges - Futhark.Representation.SegOp - Futhark.Representation.Seq - Futhark.Representation.SeqMem - Futhark.Representation.SOACS - Futhark.Representation.SOACS.Simplify - Futhark.Representation.SOACS.SOAC Futhark.Test Futhark.Test.Values Futhark.Tools @@ -223,18 +238,19 @@ Futhark.Util Futhark.Util.Console Futhark.Util.IntegralExp + Futhark.Util.Loc Futhark.Util.Log Futhark.Util.Options Futhark.Util.Pretty Futhark.Util.Table Futhark.Version Language.Futhark - Language.Futhark.Attributes Language.Futhark.Core - Language.Futhark.Prelude Language.Futhark.Interpreter Language.Futhark.Parser + Language.Futhark.Prelude Language.Futhark.Pretty + Language.Futhark.Prop Language.Futhark.Query Language.Futhark.Semantic Language.Futhark.Syntax @@ -267,7 +283,6 @@ , blaze-html >=0.9.0.1 , bytestring >=0.10.8 , containers >=0.6.2.1 - , data-binary-ieee754 >=0.1 , directory >=1.3.0.0 , directory-tree >=0.12.1 , dlist >=0.6.0.1 @@ -322,15 +337,15 @@ Futhark.BenchTests Futhark.Optimise.AlgSimplifyTests Futhark.Pkg.SolveTests - Futhark.Representation.AST.Attributes.RearrangeTests - Futhark.Representation.AST.Attributes.ReshapeTests - Futhark.Representation.AST.AttributesTests - Futhark.Representation.AST.Syntax.CoreTests - Futhark.Representation.AST.SyntaxTests - Futhark.Representation.Mem.IxFun.Alg - Futhark.Representation.Mem.IxFunTests - Futhark.Representation.Mem.IxFunWrapper - Futhark.Representation.PrimitiveTests + Futhark.IR.Prop.RearrangeTests + Futhark.IR.Prop.ReshapeTests + Futhark.IR.PropTests + Futhark.IR.Syntax.CoreTests + Futhark.IR.SyntaxTests + Futhark.IR.Mem.IxFun.Alg + Futhark.IR.Mem.IxFunTests + Futhark.IR.Mem.IxFunWrapper + Futhark.IR.PrimitiveTests Language.Futhark.CoreTests Language.Futhark.SyntaxTests Paths_futhark diff --git a/rts/c/values.h b/rts/c/values.h --- a/rts/c/values.h +++ b/rts/c/values.h @@ -2,7 +2,7 @@ //// Text I/O -typedef int (*writer)(FILE*, void*); +typedef int (*writer)(FILE*, const void*); typedef int (*bin_reader)(void*); typedef int (*str_reader)(const char *, void*); @@ -662,7 +662,11 @@ } } -static int write_str_array(FILE *out, const struct primtype_info_t *elem_type, unsigned char *data, int64_t *shape, int8_t rank) { +static int write_str_array(FILE *out, + const struct primtype_info_t *elem_type, + const unsigned char *data, + const int64_t *shape, + int8_t rank) { if (rank==0) { elem_type->write_str(out, (void*)data); } else { @@ -704,7 +708,11 @@ return 0; } -static int write_bin_array(FILE *out, const struct primtype_info_t *elem_type, unsigned char *data, int64_t *shape, int8_t rank) { +static int write_bin_array(FILE *out, + const struct primtype_info_t *elem_type, + const unsigned char *data, + const int64_t *shape, + int8_t rank) { int64_t num_elems = 1; for (int64_t i = 0; i < rank; i++) { num_elems *= shape[i]; @@ -720,7 +728,7 @@ if (IS_BIG_ENDIAN) { for (int64_t i = 0; i < num_elems; i++) { - unsigned char *elem = data+i*elem_type->size; + const unsigned char *elem = data+i*elem_type->size; for (int64_t j = 0; j < elem_type->size; j++) { fwrite(&elem[elem_type->size-j], 1, 1, out); } @@ -733,7 +741,10 @@ } static int write_array(FILE *out, int write_binary, - const struct primtype_info_t *elem_type, void *data, int64_t *shape, int8_t rank) { + const struct primtype_info_t *elem_type, + const void *data, + const int64_t *shape, + const int8_t rank) { if (write_binary) { return write_bin_array(out, elem_type, data, shape, rank); } else { diff --git a/src/Futhark/Actions.hs b/src/Futhark/Actions.hs --- a/src/Futhark/Actions.hs +++ b/src/Futhark/Actions.hs @@ -16,17 +16,17 @@ import Futhark.Pipeline import Futhark.Analysis.Alias import Futhark.Analysis.Range -import Futhark.Representation.AST -import Futhark.Representation.AST.Attributes.Aliases -import Futhark.Representation.KernelsMem (KernelsMem) -import Futhark.Representation.SeqMem (SeqMem) +import Futhark.IR +import Futhark.IR.Prop.Aliases +import Futhark.IR.KernelsMem (KernelsMem) +import Futhark.IR.SeqMem (SeqMem) import qualified Futhark.CodeGen.ImpGen.Sequential as ImpGenSequential import qualified Futhark.CodeGen.ImpGen.Kernels as ImpGenKernels -import Futhark.Representation.AST.Attributes.Ranges (CanBeRanged) +import Futhark.IR.Prop.Ranges (CanBeRanged) import Futhark.Analysis.Metrics -- | Print the result to stdout, with alias annotations. -printAction :: (Attributes lore, CanBeAliased (Op lore)) => Action lore +printAction :: (ASTLore lore, CanBeAliased (Op lore)) => Action lore printAction = Action { actionName = "Prettyprint" , actionDescription = "Prettyprint the resulting internal representation on standard output." @@ -34,7 +34,7 @@ } -- | Print the result to stdout, with range annotations. -rangeAction :: (Attributes lore, CanBeRanged (Op lore)) => Action lore +rangeAction :: (ASTLore lore, CanBeRanged (Op lore)) => Action lore rangeAction = Action { actionName = "Range analysis" , actionDescription = "Print the program with range annotations added." diff --git a/src/Futhark/Analysis/AlgSimplify.hs b/src/Futhark/Analysis/AlgSimplify.hs --- a/src/Futhark/Analysis/AlgSimplify.hs +++ b/src/Futhark/Analysis/AlgSimplify.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleInstances, LambdaCase #-} +-- | Algebraic simplification. Slow and limited. Use very rarely. module Futhark.Analysis.AlgSimplify ( ScalExp , Error @@ -18,9 +19,9 @@ import Control.Monad.Reader import Control.Monad.State -import Futhark.Representation.AST hiding (SDiv, SMod, SQuot, SRem, SSignum) +import Futhark.IR hiding (SDiv, SMod, SQuot, SRem, SSignum) import Futhark.Analysis.ScalExp -import qualified Futhark.Representation.Primitive as P +import qualified Futhark.IR.Primitive as P -- | Ranges are inclusive. type RangesRep = M.Map VName (Int, Maybe ScalExp, Maybe ScalExp) @@ -49,6 +50,7 @@ -- too much time. } +-- | Why the algebraic simplification failed. data Error = StepsExceeded | Error String type AlgSimplifyM = StateT Int (ReaderT AlgSimplifyEnv (Either Error)) @@ -445,17 +447,9 @@ e_num <- toNumSofP e_num_scal gaussAllLTH0 only_static elsyms0 e_num --- pos <- asks pos --- badAlgSimplifyM "gaussOneDefaultLTH0: unimplemented!" - ----------------------------------------------------------- ---- Pick a Symbol to Eliminate & Bring To Linear Form --- ----------------------------------------------------------- - +-- | Pick a Symbol to Eliminate & Bring To Linear Form pickSymToElim :: RangesRep -> S.Set VName -> ScalExp -> Maybe VName pickSymToElim rangesrep elsyms0 e_scal = --- ranges <- asks ranges --- e_scal <- fromNumSofP e0 let ids0= namesToList $ freeIn e_scal ids1= filter (\s -> not (S.member s elsyms0)) ids0 ids2= filter (\s -> case M.lookup s rangesrep of diff --git a/src/Futhark/Analysis/Alias.hs b/src/Futhark/Analysis/Alias.hs --- a/src/Futhark/Analysis/Alias.hs +++ b/src/Futhark/Analysis/Alias.hs @@ -3,8 +3,8 @@ -- program with an arbitrary lore and produces one with aliases. This -- module does not implement the aliasing logic itself, and derives -- its information from definitions in --- "Futhark.Representation.AST.Attributes.Aliases" and --- "Futhark.Representation.Aliases". The alias information computed +-- "Futhark.IR.Prop.Aliases" and +-- "Futhark.IR.Aliases". The alias information computed -- here will include transitive aliases (note that this is not what -- the building blocks do). module Futhark.Analysis.Alias @@ -22,16 +22,16 @@ import Data.List (foldl') import qualified Data.Map as M -import Futhark.Representation.AST.Syntax -import Futhark.Representation.Aliases +import Futhark.IR.Syntax +import Futhark.IR.Aliases -- | Perform alias analysis on a Futhark program. -aliasAnalysis :: (Attributes lore, CanBeAliased (Op lore)) => +aliasAnalysis :: (ASTLore lore, CanBeAliased (Op lore)) => Prog lore -> Prog (Aliases lore) aliasAnalysis (Prog consts funs) = Prog (fst (analyseStms mempty consts)) (map analyseFun funs) -analyseFun :: (Attributes lore, CanBeAliased (Op lore)) => +analyseFun :: (ASTLore lore, CanBeAliased (Op lore)) => FunDef lore -> FunDef (Aliases lore) analyseFun (FunDef entry fname restype params body) = FunDef entry fname restype params body' @@ -41,14 +41,14 @@ -- aliases. type AliasTable = M.Map VName Names -analyseBody :: (Attributes lore, +analyseBody :: (ASTLore lore, CanBeAliased (Op lore)) => AliasTable -> Body lore -> Body (Aliases lore) analyseBody atable (Body lore stms result) = let (stms', _atable') = analyseStms atable stms in mkAliasedBody lore stms' result -analyseStms :: (Attributes lore, CanBeAliased (Op lore)) => +analyseStms :: (ASTLore lore, CanBeAliased (Op lore)) => AliasTable -> Stms lore -> (Stms (Aliases lore), AliasesAndConsumed) analyseStms orig_aliases = foldl' f (mempty, (orig_aliases, mempty)) . stmsToList @@ -57,22 +57,22 @@ atable' = trackAliases aliases stm' in (stms<>oneStm stm', atable') -analyseStm :: (Attributes lore, CanBeAliased (Op lore)) => +analyseStm :: (ASTLore lore, CanBeAliased (Op lore)) => AliasTable -> Stm lore -> Stm (Aliases lore) -analyseStm aliases (Let pat (StmAux cs attr) e) = +analyseStm aliases (Let pat (StmAux cs attrs dec) e) = let e' = analyseExp aliases e pat' = addAliasesToPattern pat e' - lore' = (Names' $ consumedInExp e', attr) - in Let pat' (StmAux cs lore') e' + lore' = (Names' $ consumedInExp e', dec) + in Let pat' (StmAux cs attrs lore') e' -analyseExp :: (Attributes lore, CanBeAliased (Op lore)) => +analyseExp :: (ASTLore lore, CanBeAliased (Op lore)) => AliasTable -> Exp lore -> Exp (Aliases lore) -- Would be better to put this in a BranchType annotation, but that -- requires a lot of other work. -analyseExp aliases (If cond tb fb attr) = - let Body ((tb_als, tb_cons), tb_attr) tb_stms tb_res = analyseBody aliases tb - Body ((fb_als, fb_cons), fb_attr) fb_stms fb_res = analyseBody aliases fb +analyseExp aliases (If cond tb fb dec) = + let Body ((tb_als, tb_cons), tb_dec) tb_stms tb_res = analyseBody aliases tb + Body ((fb_als, fb_cons), fb_dec) fb_stms fb_res = analyseBody aliases fb cons = tb_cons <> fb_cons isConsumed v = any (`nameIn` unNames cons) $ v : namesToList (M.findWithDefault mempty v aliases) @@ -81,9 +81,9 @@ namesToList . unNames tb_als' = map notConsumed tb_als fb_als' = map notConsumed fb_als - tb' = Body ((tb_als', tb_cons), tb_attr) tb_stms tb_res - fb' = Body ((fb_als', fb_cons), fb_attr) fb_stms fb_res - in If cond tb' fb' attr + tb' = Body ((tb_als', tb_cons), tb_dec) tb_stms tb_res + fb' = Body ((fb_als', fb_cons), fb_dec) fb_stms fb_res + in If cond tb' fb' dec analyseExp aliases e = mapExp analyse e where analyse = @@ -97,7 +97,7 @@ , mapOnOp = return . addOpAliases } -analyseLambda :: (Attributes lore, CanBeAliased (Op lore)) => +analyseLambda :: (ASTLore lore, CanBeAliased (Op lore)) => Lambda lore -> Lambda (Aliases lore) analyseLambda lam = -- XXX: it may cause trouble that we pass mempty to analyseBody diff --git a/src/Futhark/Analysis/CallGraph.hs b/src/Futhark/Analysis/CallGraph.hs --- a/src/Futhark/Analysis/CallGraph.hs +++ b/src/Futhark/Analysis/CallGraph.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} -- | This module exports functionality for generating a call graph of -- an Futhark program. module Futhark.Analysis.CallGraph @@ -7,6 +8,7 @@ , calls , calledByConsts , allCalledBy + , findNoninlined ) where @@ -16,7 +18,7 @@ import Data.Maybe (fromMaybe) import Data.List (foldl') -import Futhark.Representation.SOACS +import Futhark.IR.SOACS type FunctionTable = M.Map Name (FunDef SOACS) @@ -93,3 +95,24 @@ mapOnBody = \_ body -> do tell $ buildFGBody body return body } + +-- | The set of all functions that are called noinline somewhere. +findNoninlined :: Prog SOACS -> S.Set Name +findNoninlined prog = + foldMap onStm $ foldMap (bodyStms . funDefBody) (progFuns prog) <> progConsts prog + where onStm :: Stm -> S.Set Name + onStm (Let _ aux (Apply fname _ _ _)) + | "noinline" `inAttrs` stmAuxAttrs aux = + S.singleton fname + onStm (Let _ _ e) = execWriter $ mapExpM folder e + where folder = + identityMapper + { mapOnBody = \_ body -> do tell $ foldMap onStm $ bodyStms body + return body + , mapOnOp = mapSOACM + identitySOACMapper + { mapOnSOACLambda = \lam -> do + tell $ foldMap onStm $ bodyStms $ lambdaBody lam + return lam + } + } diff --git a/src/Futhark/Analysis/DataDependencies.hs b/src/Futhark/Analysis/DataDependencies.hs --- a/src/Futhark/Analysis/DataDependencies.hs +++ b/src/Futhark/Analysis/DataDependencies.hs @@ -9,7 +9,7 @@ import qualified Data.Map.Strict as M -import Futhark.Representation.AST +import Futhark.IR -- | A mapping from a variable name @v@, to those variables on which -- the value of @v@ is dependent. The intuition is that we could @@ -18,10 +18,10 @@ type Dependencies = M.Map VName Names -- | Compute the data dependencies for an entire body. -dataDependencies :: Attributes lore => Body lore -> Dependencies +dataDependencies :: ASTLore lore => Body lore -> Dependencies dataDependencies = dataDependencies' M.empty -dataDependencies' :: Attributes lore => +dataDependencies' :: ASTLore lore => Dependencies -> Body lore -> Dependencies dataDependencies' startdeps = foldl grow startdeps . bodyStms where grow deps (Let pat _ (If c tb fb _)) = @@ -50,7 +50,13 @@ depsOfVar :: Dependencies -> VName -> Names depsOfVar deps name = oneName name <> M.findWithDefault mempty name deps -findNecessaryForReturned :: (Param attr -> Bool) -> [(Param attr, SubExp)] +-- | @findNecessaryForReturned p merge deps@ computes which of the +-- loop parameters (@merge@) are necessary for the result of the loop, +-- where @p@ given a loop parameter indicates whether the final value +-- of that parameter is live after the loop. @deps@ is the data +-- dependencies of the loop body. This is computed by straightforward +-- fixpoint iteration. +findNecessaryForReturned :: (Param dec -> Bool) -> [(Param dec, SubExp)] -> M.Map VName Names -> Names findNecessaryForReturned usedAfterLoop merge_and_res allDependencies = diff --git a/src/Futhark/Analysis/HORep/MapNest.hs b/src/Futhark/Analysis/HORep/MapNest.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/Analysis/HORep/MapNest.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TupleSections #-} +module Futhark.Analysis.HORep.MapNest + ( Nesting (..) + , MapNest (..) + , typeOf + , params + , inputs + , setInputs + , fromSOAC + , toSOAC + ) +where + +import Data.List (find) +import Data.Maybe +import qualified Data.Map.Strict as M + +import qualified Futhark.Analysis.HORep.SOAC as SOAC +import Futhark.Analysis.HORep.SOAC (SOAC) +import qualified Futhark.IR.SOACS.SOAC as Futhark +import Futhark.Transform.Substitute +import Futhark.IR hiding (typeOf) +import Futhark.MonadFreshNames +import Futhark.Construct + +data Nesting lore = Nesting { + nestingParamNames :: [VName] + , nestingResult :: [VName] + , nestingReturnType :: [Type] + , nestingWidth :: SubExp + } deriving (Eq, Ord, Show) + +data MapNest lore = MapNest SubExp (Lambda lore) [Nesting lore] [SOAC.Input] + deriving (Show) + +typeOf :: MapNest lore -> [Type] +typeOf (MapNest w lam [] _) = + map (`arrayOfRow` w) $ lambdaReturnType lam +typeOf (MapNest w _ (nest:_) _) = + map (`arrayOfRow` w) $ nestingReturnType nest + +params :: MapNest lore -> [VName] +params (MapNest _ lam [] _) = + map paramName $ lambdaParams lam +params (MapNest _ _ (nest:_) _) = + nestingParamNames nest + +inputs :: MapNest lore -> [SOAC.Input] +inputs (MapNest _ _ _ inps) = inps + +setInputs :: [SOAC.Input] -> MapNest lore -> MapNest lore +setInputs [] (MapNest w body ns _) = MapNest w body ns [] +setInputs (inp:inps) (MapNest _ body ns _) = MapNest w body ns' (inp:inps) + where w = arraySize 0 $ SOAC.inputType inp + ws = drop 1 $ arrayDims $ SOAC.inputType inp + ns' = zipWith setDepth ns ws + setDepth n nw = n { nestingWidth = nw } + +fromSOAC :: (Bindable lore, MonadFreshNames m, + LocalScope lore m, + Op lore ~ Futhark.SOAC lore) => + SOAC lore -> m (Maybe (MapNest lore)) +fromSOAC = fromSOAC' mempty + +fromSOAC' :: (Bindable lore, MonadFreshNames m, + LocalScope lore m, + Op lore ~ Futhark.SOAC lore) => + [Ident] + -> SOAC lore + -> m (Maybe (MapNest lore)) + +fromSOAC' bound (SOAC.Screma w (SOAC.ScremaForm [] [] lam) inps) = do + maybenest <- case (stmsToList $ bodyStms $ lambdaBody lam, + bodyResult $ lambdaBody lam) of + ([Let pat _ e], res) | res == map Var (patternNames pat) -> + localScope (scopeOfLParams $ lambdaParams lam) $ + SOAC.fromExp e >>= + either (return . Left) (fmap (Right . fmap (pat,)) . fromSOAC' bound') + _ -> + return $ Right Nothing + + case maybenest of + -- Do we have a nested MapNest? + Right (Just (pat, mn@(MapNest inner_w body' ns' inps'))) -> do + (ps, inps'') <- + unzip <$> + fixInputs w (zip (map paramName $ lambdaParams lam) inps) + (zip (params mn) inps') + let n' = Nesting { nestingParamNames = ps + , nestingResult = patternNames pat + , nestingReturnType = typeOf mn + , nestingWidth = inner_w + } + return $ Just $ MapNest w body' (n':ns') inps'' + -- No nested MapNest it seems. + _ -> do + let isBound name + | Just param <- find ((name==) . identName) bound = + Just param + | otherwise = + Nothing + boundUsedInBody = + mapMaybe isBound $ namesToList $ freeIn lam + newParams <- mapM (newIdent' (++"_wasfree")) boundUsedInBody + let subst = M.fromList $ + zip (map identName boundUsedInBody) (map identName newParams) + inps' = inps ++ + map (SOAC.addTransform (SOAC.Replicate mempty $ Shape [w]) . SOAC.identInput) + boundUsedInBody + lam' = + lam { lambdaBody = + substituteNames subst $ lambdaBody lam + , lambdaParams = + lambdaParams lam ++ [ Param name t + | Ident name t <- newParams ] + } + return $ Just $ MapNest w lam' [] inps' + where bound' = bound <> map paramIdent (lambdaParams lam) + +fromSOAC' _ _ = return Nothing + +toSOAC :: (MonadFreshNames m, HasScope lore m, + Bindable lore, BinderOps lore, Op lore ~ Futhark.SOAC lore) => + MapNest lore -> m (SOAC lore) +toSOAC (MapNest w lam [] inps) = + return $ SOAC.Screma w (Futhark.mapSOAC lam) inps +toSOAC (MapNest w lam (Nesting npnames nres nrettype nw:ns) inps) = do + let nparams = zipWith Param npnames $ map SOAC.inputRowType inps + body <- runBodyBinder $ localScope (scopeOfLParams nparams) $ do + letBindNames nres =<< SOAC.toExp =<< + toSOAC (MapNest nw lam ns $ map (SOAC.identInput . paramIdent) nparams) + return $ resultBody $ map Var nres + let outerlam = Lambda { lambdaParams = nparams + , lambdaBody = body + , lambdaReturnType = nrettype + } + return $ SOAC.Screma w (Futhark.mapSOAC outerlam) inps + +fixInputs :: MonadFreshNames m => + SubExp -> [(VName, SOAC.Input)] -> [(VName, SOAC.Input)] + -> m [(VName, SOAC.Input)] +fixInputs w ourInps = mapM inspect + where + isParam x (y, _) = x == y + + inspect (_, SOAC.Input ts v _) + | Just (p,pInp) <- find (isParam v) ourInps = do + let pInp' = SOAC.transformRows ts pInp + p' <- newNameFromString $ baseString p + return (p', pInp') + + inspect (param, SOAC.Input ts a t) = do + param' <- newNameFromString (baseString param ++ "_rep") + return (param', SOAC.Input (ts SOAC.|> SOAC.Replicate mempty (Shape [w])) a t) diff --git a/src/Futhark/Analysis/HORep/SOAC.hs b/src/Futhark/Analysis/HORep/SOAC.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/Analysis/HORep/SOAC.hs @@ -0,0 +1,637 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +-- | High-level representation of SOACs. When performing +-- SOAC-transformations, operating on normal 'Exp' values is somewhat +-- of a nuisance, as they can represent terms that are not proper +-- SOACs. In contrast, this module exposes a SOAC representation that +-- does not enable invalid representations (except for type errors). +-- +-- Furthermore, while standard normalised Futhark requires that the inputs +-- to a SOAC are variables or constants, the representation in this +-- module also supports various index-space transformations, like +-- @replicate@ or @rearrange@. This is also very convenient when +-- implementing transformations. +-- +-- The names exported by this module conflict with the standard Futhark +-- syntax tree constructors, so you are advised to use a qualified +-- import: +-- +-- @ +-- import Futhark.Analysis.HORep.SOAC (SOAC) +-- import qualified Futhark.Analysis.HORep.SOAC as SOAC +-- @ +module Futhark.Analysis.HORep.SOAC + ( + -- * SOACs + SOAC (..) + , Futhark.ScremaForm(..) + , inputs + , setInputs + , lambda + , setLambda + , typeOf + , width + -- ** Converting to and from expressions + , NotSOAC (..) + , fromExp + , toExp + , toSOAC + -- * SOAC inputs + , Input (..) + , varInput + , identInput + , isVarInput + , isVarishInput + , addTransform + , addInitialTransforms + , inputArray + , inputRank + , inputType + , inputRowType + , transformRows + , transposeInput + -- ** Input transformations + , ArrayTransforms + , noTransforms + , nullTransforms + , (|>) + , (<|) + , viewf + , ViewF(..) + , viewl + , ViewL(..) + , ArrayTransform(..) + , transformFromExp + , soacToStream + ) + where + +import Data.Foldable as Foldable +import Data.Maybe +import qualified Data.Sequence as Seq + +import qualified Futhark.IR as Futhark +import Futhark.IR.SOACS.SOAC + (StreamForm(..), ScremaForm(..), scremaType, getStreamAccums, HistOp(..), StreamOrd(..)) +import qualified Futhark.IR.SOACS.SOAC as Futhark +import Futhark.IR + hiding (Var, Iota, Rearrange, Reshape, Replicate, typeOf) +import Futhark.Transform.Substitute +import Futhark.Construct hiding (toExp) +import Futhark.Transform.Rename (renameLambda) +import qualified Futhark.Util.Pretty as PP +import Futhark.Util.Pretty (ppr, text) + +-- | A single, simple transformation. If you want several, don't just +-- create a list, use 'ArrayTransforms' instead. +data ArrayTransform = Rearrange Certificates [Int] + -- ^ A permutation of an otherwise valid input. + | Reshape Certificates (ShapeChange SubExp) + -- ^ A reshaping of an otherwise valid input. + | ReshapeOuter Certificates (ShapeChange SubExp) + -- ^ A reshaping of the outer dimension. + | ReshapeInner Certificates (ShapeChange SubExp) + -- ^ A reshaping of everything but the outer dimension. + | Replicate Certificates Shape + -- ^ Replicate the rows of the array a number of times. + deriving (Show, Eq, Ord) + +instance Substitute ArrayTransform where + substituteNames substs (Rearrange cs xs) = + Rearrange (substituteNames substs cs) xs + substituteNames substs (Reshape cs ses) = + Reshape (substituteNames substs cs) (substituteNames substs ses) + substituteNames substs (ReshapeOuter cs ses) = + ReshapeOuter (substituteNames substs cs) (substituteNames substs ses) + substituteNames substs (ReshapeInner cs ses) = + ReshapeInner (substituteNames substs cs) (substituteNames substs ses) + substituteNames substs (Replicate cs se) = + Replicate (substituteNames substs cs) (substituteNames substs se) + +-- | A sequence of array transformations, heavily inspired by +-- "Data.Seq". You can decompose it using 'viewf' and 'viewl', and +-- grow it by using '|>' and '<|'. These correspond closely to the +-- similar operations for sequences, except that appending will try to +-- normalise and simplify the transformation sequence. +-- +-- The data type is opaque in order to enforce normalisation +-- invariants. Basically, when you grow the sequence, the +-- implementation will try to coalesce neighboring permutations, for +-- example by composing permutations and removing identity +-- transformations. +newtype ArrayTransforms = ArrayTransforms (Seq.Seq ArrayTransform) + deriving (Eq, Ord, Show) + +instance Semigroup ArrayTransforms where + ts1 <> ts2 = case viewf ts2 of + t :< ts2' -> (ts1 |> t) <> ts2' + EmptyF -> ts1 + +instance Monoid ArrayTransforms where + mempty = noTransforms + +instance Substitute ArrayTransforms where + substituteNames substs (ArrayTransforms ts) = + ArrayTransforms $ substituteNames substs <$> ts + +-- | The empty transformation list. +noTransforms :: ArrayTransforms +noTransforms = ArrayTransforms Seq.empty + +-- | Is it an empty transformation list? +nullTransforms :: ArrayTransforms -> Bool +nullTransforms (ArrayTransforms s) = Seq.null s + +-- | Decompose the input-end of the transformation sequence. +viewf :: ArrayTransforms -> ViewF +viewf (ArrayTransforms s) = case Seq.viewl s of + t Seq.:< s' -> t :< ArrayTransforms s' + Seq.EmptyL -> EmptyF + +-- | A view of the first transformation to be applied. +data ViewF = EmptyF + | ArrayTransform :< ArrayTransforms + +-- | Decompose the output-end of the transformation sequence. +viewl :: ArrayTransforms -> ViewL +viewl (ArrayTransforms s) = case Seq.viewr s of + s' Seq.:> t -> ArrayTransforms s' :> t + Seq.EmptyR -> EmptyL + +-- | A view of the last transformation to be applied. +data ViewL = EmptyL + | ArrayTransforms :> ArrayTransform + +-- | Add a transform to the end of the transformation list. +(|>) :: ArrayTransforms -> ArrayTransform -> ArrayTransforms +(|>) = flip $ addTransform' extract add $ uncurry (flip (,)) + where extract ts' = case viewl ts' of + EmptyL -> Nothing + ts'' :> t' -> Just (t', ts'') + add t' (ArrayTransforms ts') = ArrayTransforms $ ts' Seq.|> t' + +-- | Add a transform at the beginning of the transformation list. +(<|) :: ArrayTransform -> ArrayTransforms -> ArrayTransforms +(<|) = addTransform' extract add id + where extract ts' = case viewf ts' of + EmptyF -> Nothing + t' :< ts'' -> Just (t', ts'') + add t' (ArrayTransforms ts') = ArrayTransforms $ t' Seq.<| ts' + +addTransform' :: (ArrayTransforms -> Maybe (ArrayTransform, ArrayTransforms)) + -> (ArrayTransform -> ArrayTransforms -> ArrayTransforms) + -> ((ArrayTransform,ArrayTransform) -> (ArrayTransform,ArrayTransform)) + -> ArrayTransform -> ArrayTransforms + -> ArrayTransforms +addTransform' extract add swap t ts = + fromMaybe (t `add` ts) $ do + (t', ts') <- extract ts + combined <- uncurry combineTransforms $ swap (t', t) + Just $ if identityTransform combined then ts' + else addTransform' extract add swap combined ts' + +identityTransform :: ArrayTransform -> Bool +identityTransform (Rearrange _ perm) = + Foldable.and $ zipWith (==) perm [0..] +identityTransform _ = False + +combineTransforms :: ArrayTransform -> ArrayTransform -> Maybe ArrayTransform +combineTransforms (Rearrange cs2 perm2) (Rearrange cs1 perm1) = + Just $ Rearrange (cs1<>cs2) $ perm2 `rearrangeCompose` perm1 +combineTransforms _ _ = Nothing + +-- | Given an expression, determine whether the expression represents +-- an input transformation of an array variable. If so, return the +-- variable and the transformation. Only 'Rearrange' and 'Reshape' +-- are possible to express this way. +transformFromExp :: Certificates -> Exp lore -> Maybe (VName, ArrayTransform) +transformFromExp cs (BasicOp (Futhark.Rearrange perm v)) = + Just (v, Rearrange cs perm) +transformFromExp cs (BasicOp (Futhark.Reshape shape v)) = + Just (v, Reshape cs shape) +transformFromExp cs (BasicOp (Futhark.Replicate shape (Futhark.Var v))) = + Just (v, Replicate cs shape) +transformFromExp _ _ = Nothing + +-- | One array input to a SOAC - a SOAC may have multiple inputs, but +-- all are of this form. Only the array inputs are expressed with +-- this type; other arguments, such as initial accumulator values, are +-- plain expressions. The transforms are done left-to-right, that is, +-- the first element of the 'ArrayTransform' list is applied first. +data Input = Input ArrayTransforms VName Type + deriving (Show, Eq, Ord) + +instance Substitute Input where + substituteNames substs (Input ts v t) = + Input (substituteNames substs ts) + (substituteNames substs v) (substituteNames substs t) + +-- | Create a plain array variable input with no transformations. +varInput :: HasScope t f => VName -> f Input +varInput v = withType <$> lookupType v + where withType = Input (ArrayTransforms Seq.empty) v + +-- | Create a plain array variable input with no transformations, from an 'Ident'. +identInput :: Ident -> Input +identInput v = Input (ArrayTransforms Seq.empty) (identName v) (identType v) + +-- | If the given input is a plain variable input, with no transforms, +-- return the variable. +isVarInput :: Input -> Maybe VName +isVarInput (Input ts v _) | nullTransforms ts = Just v +isVarInput _ = Nothing + +-- | If the given input is a plain variable input, with no non-vacuous transforms, +-- return the variable. +isVarishInput :: Input -> Maybe VName +isVarishInput (Input ts v t) + | nullTransforms ts = Just v + | Reshape cs [DimCoercion _] :< ts' <- viewf ts, cs == mempty = + isVarishInput $ Input ts' v t +isVarishInput _ = Nothing + +-- | Add a transformation to the end of the transformation list. +addTransform :: ArrayTransform -> Input -> Input +addTransform tr (Input trs a t) = + Input (trs |> tr) a t + +-- | Add several transformations to the start of the transformation +-- list. +addInitialTransforms :: ArrayTransforms -> Input -> Input +addInitialTransforms ts (Input ots a t) = Input (ts <> ots) a t + +-- | Convert SOAC inputs to the corresponding expressions. +inputsToSubExps :: (MonadBinder m) => + [Input] -> m [VName] +inputsToSubExps = mapM inputToExp' + where inputToExp' (Input (ArrayTransforms ts) a _) = + foldlM transform a ts + + transform ia (Replicate cs n) = + certifying cs $ + letExp "repeat" $ BasicOp $ Futhark.Replicate n (Futhark.Var ia) + + transform ia (Rearrange cs perm) = + certifying cs $ + letExp "rearrange" $ BasicOp $ Futhark.Rearrange perm ia + + transform ia (Reshape cs shape) = + certifying cs $ + letExp "reshape" $ BasicOp $ Futhark.Reshape shape ia + + transform ia (ReshapeOuter cs shape) = do + shape' <- reshapeOuter shape 1 . arrayShape <$> lookupType ia + certifying cs $ + letExp "reshape_outer" $ BasicOp $ Futhark.Reshape shape' ia + + transform ia (ReshapeInner cs shape) = do + shape' <- reshapeInner shape 1 . arrayShape <$> lookupType ia + certifying cs $ + letExp "reshape_inner" $ BasicOp $ Futhark.Reshape shape' ia + +-- | Return the array name of the input. +inputArray :: Input -> VName +inputArray (Input _ v _) = v + +-- | Return the type of an input. +inputType :: Input -> Type +inputType (Input (ArrayTransforms ts) _ at) = + Foldable.foldl transformType at ts + where transformType t (Replicate _ shape) = + arrayOfShape t shape + transformType t (Rearrange _ perm) = + rearrangeType perm t + transformType t (Reshape _ shape) = + t `setArrayShape` newShape shape + transformType t (ReshapeOuter _ shape) = + let Shape oldshape = arrayShape t + in t `setArrayShape` Shape (newDims shape ++ drop 1 oldshape) + transformType t (ReshapeInner _ shape) = + let Shape oldshape = arrayShape t + in t `setArrayShape` Shape (take 1 oldshape ++ newDims shape) + +-- | Return the row type of an input. Just a convenient alias. +inputRowType :: Input -> Type +inputRowType = rowType . inputType + +-- | Return the array rank (dimensionality) of an input. Just a +-- convenient alias. +inputRank :: Input -> Int +inputRank = arrayRank . inputType + +-- | Apply the transformations to every row of the input. +transformRows :: ArrayTransforms -> Input -> Input +transformRows (ArrayTransforms ts) = + flip (Foldable.foldl transformRows') ts + where transformRows' inp (Rearrange cs perm) = + addTransform (Rearrange cs (0:map (+1) perm)) inp + transformRows' inp (Reshape cs shape) = + addTransform (ReshapeInner cs shape) inp + transformRows' inp (Replicate cs n) + | inputRank inp == 1 = + Rearrange mempty [1,0] `addTransform` + (Replicate cs n `addTransform` inp) + | otherwise = + Rearrange mempty (2:0:1:[3..inputRank inp]) `addTransform` + (Replicate cs n `addTransform` + (Rearrange mempty (1:0:[2..inputRank inp-1]) `addTransform` inp)) + transformRows' inp nts = + error $ "transformRows: Cannot transform this yet:\n" ++ show nts ++ "\n" ++ show inp + +-- | Add to the input a 'Rearrange' transform that performs an @(k,n)@ +-- transposition. The new transform will be at the end of the current +-- transformation list. +transposeInput :: Int -> Int -> Input -> Input +transposeInput k n inp = + addTransform (Rearrange mempty $ transposeIndex k n [0..inputRank inp-1]) inp + +-- | A definite representation of a SOAC expression. +data SOAC lore = Stream SubExp (StreamForm lore) (Lambda lore) [Input] + | Scatter SubExp (Lambda lore) [Input] [(SubExp, Int, VName)] + | Screma SubExp (ScremaForm lore) [Input] + | Hist SubExp [HistOp lore] (Lambda lore) [Input] + deriving (Eq, Show) + +instance PP.Pretty Input where + ppr (Input (ArrayTransforms ts) arr _) = foldl f (ppr arr) ts + where f e (Rearrange cs perm) = + text "rearrange" <> ppr cs <> PP.apply [PP.apply (map ppr perm), e] + f e (Reshape cs shape) = + text "reshape" <> ppr cs <> PP.apply [PP.apply (map ppr shape), e] + f e (ReshapeOuter cs shape) = + text "reshape_outer" <> ppr cs <> PP.apply [PP.apply (map ppr shape), e] + f e (ReshapeInner cs shape) = + text "reshape_inner" <> ppr cs <> PP.apply [PP.apply (map ppr shape), e] + f e (Replicate cs ne) = + text "replicate" <> ppr cs <> PP.apply [ppr ne, e] + +instance PrettyLore lore => PP.Pretty (SOAC lore) where + ppr (Screma w form arrs) = Futhark.ppScrema w form arrs + ppr (Hist len ops bucket_fun imgs) = + Futhark.ppHist len ops bucket_fun imgs + ppr soac = text $ show soac + +-- | Returns the inputs used in a SOAC. +inputs :: SOAC lore -> [Input] +inputs (Stream _ _ _ arrs) = arrs +inputs (Scatter _len _lam ivs _as) = ivs +inputs (Screma _ _ arrs) = arrs +inputs (Hist _ _ _ inps) = inps + +-- | Set the inputs to a SOAC. +setInputs :: [Input] -> SOAC lore -> SOAC lore +setInputs arrs (Stream w form lam _) = + Stream (newWidth arrs w) form lam arrs +setInputs arrs (Scatter w lam _ivs as) = + Scatter (newWidth arrs w) lam arrs as +setInputs arrs (Screma w form _) = + Screma w form arrs +setInputs inps (Hist w ops lam _) = + Hist w ops lam inps + +newWidth :: [Input] -> SubExp -> SubExp +newWidth [] w = w +newWidth (inp:_) _ = arraySize 0 $ inputType inp + +-- | The lambda used in a given SOAC. +lambda :: SOAC lore -> Lambda lore +lambda (Stream _ _ lam _) = lam +lambda (Scatter _len lam _ivs _as) = lam +lambda (Screma _ (ScremaForm _ _ lam) _) = lam +lambda (Hist _ _ lam _) = lam + +-- | Set the lambda used in the SOAC. +setLambda :: Lambda lore -> SOAC lore -> SOAC lore +setLambda lam (Stream w form _ arrs) = + Stream w form lam arrs +setLambda lam (Scatter len _lam ivs as) = + Scatter len lam ivs as +setLambda lam (Screma w (ScremaForm scan red _) arrs) = + Screma w (ScremaForm scan red lam) arrs +setLambda lam (Hist w ops _ inps) = + Hist w ops lam inps + +-- | The return type of a SOAC. +typeOf :: SOAC lore -> [Type] +typeOf (Stream w form lam _) = + let nes = getStreamAccums form + accrtps = take (length nes) $ lambdaReturnType lam + arrtps = [ arrayOf (stripArray 1 t) (Shape [w]) NoUniqueness + | t <- drop (length nes) (lambdaReturnType lam) ] + in accrtps ++ arrtps +typeOf (Scatter _w lam _ivs dests) = + zipWith arrayOfRow (drop (n `div` 2) lam_ts) aws + where lam_ts = lambdaReturnType lam + n = length lam_ts + (aws, _, _) = unzip3 dests +typeOf (Screma w form _) = + scremaType w form +typeOf (Hist _ ops _ _) = do + op <- ops + map (`arrayOfRow` histWidth op) (lambdaReturnType $ histOp op) + +-- | The "width" of a SOAC is the expected outer size of its array +-- inputs _after_ input-transforms have been carried out. +width :: SOAC lore -> SubExp +width (Stream w _ _ _) = w +width (Scatter len _lam _ivs _as) = len +width (Screma w _ _) = w +width (Hist w _ _ _) = w + +-- | Convert a SOAC to the corresponding expression. +toExp :: (MonadBinder m, Op (Lore m) ~ Futhark.SOAC (Lore m)) => + SOAC (Lore m) -> m (Exp (Lore m)) +toExp soac = Op <$> toSOAC soac + +-- | Convert a SOAC to a Futhark-level SOAC. +toSOAC :: MonadBinder m => + SOAC (Lore m) -> m (Futhark.SOAC (Lore m)) +toSOAC (Stream w form lam inps) = + Futhark.Stream w form lam <$> inputsToSubExps inps +toSOAC (Scatter len lam ivs dests) = do + ivs' <- inputsToSubExps ivs + return $ Futhark.Scatter len lam ivs' dests +toSOAC (Screma w form arrs) = + Futhark.Screma w form <$> inputsToSubExps arrs +toSOAC (Hist w ops lam inps) = + Futhark.Hist w ops lam <$> inputsToSubExps inps + +-- | The reason why some expression cannot be converted to a 'SOAC' +-- value. +data NotSOAC = NotSOAC -- ^ The expression is not a (tuple-)SOAC at all. + deriving (Show) + +-- | Either convert an expression to the normalised SOAC +-- representation, or a reason why the expression does not have the +-- valid form. +fromExp :: (Op lore ~ Futhark.SOAC lore, HasScope lore m) => + Exp lore -> m (Either NotSOAC (SOAC lore)) +fromExp (Op (Futhark.Stream w form lam as)) = + Right . Stream w form lam <$> traverse varInput as +fromExp (Op (Futhark.Scatter len lam ivs as)) = + Right <$> (Scatter len lam <$> traverse varInput ivs <*> pure as) +fromExp (Op (Futhark.Screma w form arrs)) = + Right . Screma w form <$> traverse varInput arrs +fromExp (Op (Futhark.Hist w ops lam arrs)) = + Right . Hist w ops lam <$> traverse varInput arrs +fromExp _ = pure $ Left NotSOAC + +-- | To-Stream translation of SOACs. +-- Returns the Stream SOAC and the +-- extra-accumulator body-result ident if any. +soacToStream :: (MonadFreshNames m, Bindable lore, Op lore ~ Futhark.SOAC lore) => + SOAC lore -> m (SOAC lore,[Ident]) +soacToStream soac = do + chunk_param <- newParam "chunk" $ Prim int32 + let chvar= Futhark.Var $ paramName chunk_param + (lam, inps) = (lambda soac, inputs soac) + w = width soac + lam' <- renameLambda lam + let arrrtps= mapType w lam + -- the chunked-outersize of the array result and input types + loutps = [ arrayOfRow t chvar | t <- map rowType arrrtps ] + lintps = [ arrayOfRow t chvar | t <- map inputRowType inps ] + + strm_inpids <- mapM (newParam "inp") lintps + -- Treat each SOAC case individually: + case soac of + Screma _ form _ + | Just _ <- Futhark.isMapSOAC form -> do + -- Map(f,a) => is translated in strem's body to: + -- let strm_resids = map(f,a_ch) in strm_resids + -- + -- array result and input IDs of the stream's lambda + strm_resids <- mapM (newIdent "res") loutps + let insoac = Futhark.Screma chvar (Futhark.mapSOAC lam') $ map paramName strm_inpids + insbnd = mkLet [] strm_resids $ Op insoac + strmbdy= mkBody (oneStm insbnd) $ map (Futhark.Var . identName) strm_resids + strmpar= chunk_param:strm_inpids + strmlam= Lambda strmpar strmbdy loutps + empty_lam = Lambda [] (mkBody mempty []) [] + -- map(f,a) creates a stream with NO accumulators + return (Stream w (Parallel Disorder Commutative empty_lam []) strmlam inps, []) + + | Just (scans, _) <- Futhark.isScanomapSOAC form, + Futhark.Scan scan_lam nes <- Futhark.singleScan scans -> do + -- scanomap(scan_lam,nes,map_lam,a) => is translated in strem's body to: + -- 1. let (scan0_ids,map_resids) = scanomap(scan_lam, nes, map_lam, a_ch) + -- 2. let strm_resids = map (acc `+`,nes, scan0_ids) + -- 3. let outerszm1id = sizeof(0,strm_resids) - 1 + -- 4. let lasteel_ids = if outerszm1id < 0 + -- then nes + -- else strm_resids[outerszm1id] + -- 5. let acc' = acc + lasteel_ids + -- {acc', strm_resids, map_resids} + -- the array and accumulator result types + let scan_arr_ts = map (`arrayOfRow` chvar) $ lambdaReturnType scan_lam + map_arr_ts = drop (length nes) loutps + accrtps = lambdaReturnType scan_lam + + -- array result and input IDs of the stream's lambda + strm_resids <- mapM (newIdent "res") scan_arr_ts + scan0_ids <- mapM (newIdent "resarr0") scan_arr_ts + map_resids <- mapM (newIdent "map_res") map_arr_ts + + lastel_ids <- mapM (newIdent "lstel") accrtps + lastel_tmp_ids <- mapM (newIdent "lstel_tmp") accrtps + empty_arr <- newIdent "empty_arr" $ Prim Bool + inpacc_ids <- mapM (newParam "inpacc") accrtps + outszm1id <- newIdent "szm1" $ Prim int32 + -- 1. let (scan0_ids,map_resids) = scanomap(scan_lam,nes,map_lam,a_ch) + let insbnd = mkLet [] (scan0_ids++map_resids) $ Op $ + Futhark.Screma chvar (Futhark.scanomapSOAC [Futhark.Scan scan_lam nes] lam') $ + map paramName strm_inpids + -- 2. let outerszm1id = chunksize - 1 + outszm1bnd = mkLet [] [outszm1id] $ BasicOp $ + BinOp (Sub Int32 OverflowUndef) + (Futhark.Var $ paramName chunk_param) + (constant (1::Int32)) + -- 3. let lasteel_ids = ... + empty_arr_bnd = mkLet [] [empty_arr] $ BasicOp $ CmpOp (CmpSlt Int32) + (Futhark.Var $ identName outszm1id) + (constant (0::Int32)) + leltmpbnds= zipWith (\ lid arrid -> mkLet [] [lid] $ BasicOp $ + Index (identName arrid) $ + fullSlice (identType arrid) + [DimFix $ Futhark.Var $ identName outszm1id] + ) lastel_tmp_ids scan0_ids + lelbnd = mkLet [] lastel_ids $ + If (Futhark.Var $ identName empty_arr) + (mkBody mempty nes) + (mkBody (stmsFromList leltmpbnds) $ + map (Futhark.Var . identName) lastel_tmp_ids) $ + ifCommon $ map identType lastel_tmp_ids + -- 4. let strm_resids = map (acc `+`,nes, scan0_ids) + maplam <- mkMapPlusAccLam (map (Futhark.Var . paramName) inpacc_ids) scan_lam + let mapbnd = mkLet [] strm_resids $ Op $ + Futhark.Screma chvar (Futhark.mapSOAC maplam) $ + map identName scan0_ids + -- 5. let acc' = acc + lasteel_ids + addlelbdy <- mkPlusBnds scan_lam $ map Futhark.Var $ + map paramName inpacc_ids++map identName lastel_ids + -- Finally, construct the stream + let (addlelbnd,addlelres) = (bodyStms addlelbdy, bodyResult addlelbdy) + strmbdy= mkBody (stmsFromList [insbnd,outszm1bnd,empty_arr_bnd,lelbnd,mapbnd]<>addlelbnd) $ + addlelres ++ map (Futhark.Var . identName) (strm_resids ++ map_resids) + strmpar= chunk_param:inpacc_ids++strm_inpids + strmlam= Lambda strmpar strmbdy (accrtps++loutps) + return (Stream w (Sequential nes) strmlam inps, + map paramIdent inpacc_ids) + + | Just (reds, _) <- Futhark.isRedomapSOAC form, + Futhark.Reduce comm lamin nes <- Futhark.singleReduce reds -> do + -- Redomap(+,lam,nes,a) => is translated in strem's body to: + -- 1. let (acc0_ids,strm_resids) = redomap(+,lam,nes,a_ch) in + -- 2. let acc' = acc + acc0_ids in + -- {acc', strm_resids} + + let accrtps= take (length nes) $ lambdaReturnType lam + -- the chunked-outersize of the array result and input types + loutps' = drop (length nes) loutps + -- the lambda with proper index + foldlam = lam' + -- array result and input IDs of the stream's lambda + strm_resids <- mapM (newIdent "res") loutps' + inpacc_ids <- mapM (newParam "inpacc") accrtps + acc0_ids <- mapM (newIdent "acc0" ) accrtps + -- 1. let (acc0_ids,strm_resids) = redomap(+,lam,nes,a_ch) in + let insoac = Futhark.Screma chvar + (Futhark.redomapSOAC [Futhark.Reduce comm lamin nes] foldlam) $ + map paramName strm_inpids + insbnd = mkLet [] (acc0_ids++strm_resids) $ Op insoac + -- 2. let acc' = acc + acc0_ids in + addaccbdy <- mkPlusBnds lamin $ map Futhark.Var $ + map paramName inpacc_ids++map identName acc0_ids + -- Construct the stream + let (addaccbnd,addaccres) = (bodyStms addaccbdy, bodyResult addaccbdy) + strmbdy= mkBody (oneStm insbnd <> addaccbnd) $ + addaccres ++ map (Futhark.Var . identName) strm_resids + strmpar= chunk_param:inpacc_ids++strm_inpids + strmlam= Lambda strmpar strmbdy (accrtps++loutps') + lam0 <- renameLambda lamin + return (Stream w (Parallel InOrder comm lam0 nes) strmlam inps, []) + + -- Otherwise it cannot become a stream. + _ -> return (soac,[]) + where mkMapPlusAccLam :: (MonadFreshNames m, Bindable lore) + => [SubExp] -> Lambda lore -> m (Lambda lore) + mkMapPlusAccLam accs plus = do + let (accpars, rempars) = splitAt (length accs) $ lambdaParams plus + parbnds = zipWith (\ par se -> mkLet [] [paramIdent par] + (BasicOp $ SubExp se) + ) accpars accs + plus_bdy = lambdaBody plus + newlambdy = Body (bodyDec plus_bdy) + (stmsFromList parbnds <> bodyStms plus_bdy) + (bodyResult plus_bdy) + renameLambda $ Lambda rempars newlambdy $ lambdaReturnType plus + + mkPlusBnds :: (MonadFreshNames m, Bindable lore) + => Lambda lore -> [SubExp] -> m (Body lore) + mkPlusBnds plus accels = do + plus' <- renameLambda plus + let parbnds = zipWith (\ par se -> mkLet [] [paramIdent par] + (BasicOp $ SubExp se) + ) (lambdaParams plus') accels + body = lambdaBody plus' + return $ body { bodyStms = stmsFromList parbnds <> bodyStms body } diff --git a/src/Futhark/Analysis/HORepresentation/MapNest.hs b/src/Futhark/Analysis/HORepresentation/MapNest.hs deleted file mode 100644 --- a/src/Futhark/Analysis/HORepresentation/MapNest.hs +++ /dev/null @@ -1,155 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TupleSections #-} -module Futhark.Analysis.HORepresentation.MapNest - ( Nesting (..) - , MapNest (..) - , typeOf - , params - , inputs - , setInputs - , fromSOAC - , toSOAC - ) -where - -import Data.List (find) -import Data.Maybe -import qualified Data.Map.Strict as M - -import qualified Futhark.Analysis.HORepresentation.SOAC as SOAC -import Futhark.Analysis.HORepresentation.SOAC (SOAC) -import qualified Futhark.Representation.SOACS.SOAC as Futhark -import Futhark.Transform.Substitute -import Futhark.Representation.AST hiding (typeOf) -import Futhark.MonadFreshNames -import Futhark.Construct - -data Nesting lore = Nesting { - nestingParamNames :: [VName] - , nestingResult :: [VName] - , nestingReturnType :: [Type] - , nestingWidth :: SubExp - } deriving (Eq, Ord, Show) - -data MapNest lore = MapNest SubExp (Lambda lore) [Nesting lore] [SOAC.Input] - deriving (Show) - -typeOf :: MapNest lore -> [Type] -typeOf (MapNest w lam [] _) = - map (`arrayOfRow` w) $ lambdaReturnType lam -typeOf (MapNest w _ (nest:_) _) = - map (`arrayOfRow` w) $ nestingReturnType nest - -params :: MapNest lore -> [VName] -params (MapNest _ lam [] _) = - map paramName $ lambdaParams lam -params (MapNest _ _ (nest:_) _) = - nestingParamNames nest - -inputs :: MapNest lore -> [SOAC.Input] -inputs (MapNest _ _ _ inps) = inps - -setInputs :: [SOAC.Input] -> MapNest lore -> MapNest lore -setInputs [] (MapNest w body ns _) = MapNest w body ns [] -setInputs (inp:inps) (MapNest _ body ns _) = MapNest w body ns' (inp:inps) - where w = arraySize 0 $ SOAC.inputType inp - ws = drop 1 $ arrayDims $ SOAC.inputType inp - ns' = zipWith setDepth ns ws - setDepth n nw = n { nestingWidth = nw } - -fromSOAC :: (Bindable lore, MonadFreshNames m, - LocalScope lore m, - Op lore ~ Futhark.SOAC lore) => - SOAC lore -> m (Maybe (MapNest lore)) -fromSOAC = fromSOAC' mempty - -fromSOAC' :: (Bindable lore, MonadFreshNames m, - LocalScope lore m, - Op lore ~ Futhark.SOAC lore) => - [Ident] - -> SOAC lore - -> m (Maybe (MapNest lore)) - -fromSOAC' bound (SOAC.Screma w (SOAC.ScremaForm [] [] lam) inps) = do - maybenest <- case (stmsToList $ bodyStms $ lambdaBody lam, - bodyResult $ lambdaBody lam) of - ([Let pat _ e], res) | res == map Var (patternNames pat) -> - localScope (scopeOfLParams $ lambdaParams lam) $ - SOAC.fromExp e >>= - either (return . Left) (fmap (Right . fmap (pat,)) . fromSOAC' bound') - _ -> - return $ Right Nothing - - case maybenest of - -- Do we have a nested MapNest? - Right (Just (pat, mn@(MapNest inner_w body' ns' inps'))) -> do - (ps, inps'') <- - unzip <$> - fixInputs w (zip (map paramName $ lambdaParams lam) inps) - (zip (params mn) inps') - let n' = Nesting { nestingParamNames = ps - , nestingResult = patternNames pat - , nestingReturnType = typeOf mn - , nestingWidth = inner_w - } - return $ Just $ MapNest w body' (n':ns') inps'' - -- No nested MapNest it seems. - _ -> do - let isBound name - | Just param <- find ((name==) . identName) bound = - Just param - | otherwise = - Nothing - boundUsedInBody = - mapMaybe isBound $ namesToList $ freeIn lam - newParams <- mapM (newIdent' (++"_wasfree")) boundUsedInBody - let subst = M.fromList $ - zip (map identName boundUsedInBody) (map identName newParams) - inps' = inps ++ - map (SOAC.addTransform (SOAC.Replicate mempty $ Shape [w]) . SOAC.identInput) - boundUsedInBody - lam' = - lam { lambdaBody = - substituteNames subst $ lambdaBody lam - , lambdaParams = - lambdaParams lam ++ [ Param name t - | Ident name t <- newParams ] - } - return $ Just $ MapNest w lam' [] inps' - where bound' = bound <> map paramIdent (lambdaParams lam) - -fromSOAC' _ _ = return Nothing - -toSOAC :: (MonadFreshNames m, HasScope lore m, - Bindable lore, BinderOps lore, Op lore ~ Futhark.SOAC lore) => - MapNest lore -> m (SOAC lore) -toSOAC (MapNest w lam [] inps) = - return $ SOAC.Screma w (Futhark.mapSOAC lam) inps -toSOAC (MapNest w lam (Nesting npnames nres nrettype nw:ns) inps) = do - let nparams = zipWith Param npnames $ map SOAC.inputRowType inps - (e,bnds) <- runBinder $ localScope (scopeOfLParams nparams) $ SOAC.toExp =<< - toSOAC (MapNest nw lam ns $ map (SOAC.identInput . paramIdent) nparams) - bnd <- mkLetNames nres e - let outerlam = Lambda { lambdaParams = nparams - , lambdaBody = mkBody (bnds<>oneStm bnd) $ map Var nres - , lambdaReturnType = nrettype - } - return $ SOAC.Screma w (Futhark.mapSOAC outerlam) inps - -fixInputs :: MonadFreshNames m => - SubExp -> [(VName, SOAC.Input)] -> [(VName, SOAC.Input)] - -> m [(VName, SOAC.Input)] -fixInputs w ourInps = mapM inspect - where - isParam x (y, _) = x == y - - inspect (_, SOAC.Input ts v _) - | Just (p,pInp) <- find (isParam v) ourInps = do - let pInp' = SOAC.transformRows ts pInp - p' <- newNameFromString $ baseString p - return (p', pInp') - - inspect (param, SOAC.Input ts a t) = do - param' <- newNameFromString (baseString param ++ "_rep") - return (param', SOAC.Input (ts SOAC.|> SOAC.Replicate mempty (Shape [w])) a t) diff --git a/src/Futhark/Analysis/HORepresentation/SOAC.hs b/src/Futhark/Analysis/HORepresentation/SOAC.hs deleted file mode 100644 --- a/src/Futhark/Analysis/HORepresentation/SOAC.hs +++ /dev/null @@ -1,637 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} --- | High-level representation of SOACs. When performing --- SOAC-transformations, operating on normal 'Exp' values is somewhat --- of a nuisance, as they can represent terms that are not proper --- SOACs. In contrast, this module exposes a SOAC representation that --- does not enable invalid representations (except for type errors). --- --- Furthermore, while standard normalised Futhark requires that the inputs --- to a SOAC are variables or constants, the representation in this --- module also supports various index-space transformations, like --- @replicate@ or @rearrange@. This is also very convenient when --- implementing transformations. --- --- The names exported by this module conflict with the standard Futhark --- syntax tree constructors, so you are advised to use a qualified --- import: --- --- @ --- import Futhark.Analysis.HORepresentation.SOAC (SOAC) --- import qualified Futhark.Analysis.HORepresentation.SOAC as SOAC --- @ -module Futhark.Analysis.HORepresentation.SOAC - ( - -- * SOACs - SOAC (..) - , Futhark.ScremaForm(..) - , inputs - , setInputs - , lambda - , setLambda - , typeOf - , width - -- ** Converting to and from expressions - , NotSOAC (..) - , fromExp - , toExp - , toSOAC - -- * SOAC inputs - , Input (..) - , varInput - , identInput - , isVarInput - , isVarishInput - , addTransform - , addInitialTransforms - , inputArray - , inputRank - , inputType - , inputRowType - , transformRows - , transposeInput - -- ** Input transformations - , ArrayTransforms - , noTransforms - , nullTransforms - , (|>) - , (<|) - , viewf - , ViewF(..) - , viewl - , ViewL(..) - , ArrayTransform(..) - , transformFromExp - , soacToStream - ) - where - -import Data.Foldable as Foldable -import Data.Maybe -import qualified Data.Sequence as Seq - -import qualified Futhark.Representation.AST as Futhark -import Futhark.Representation.SOACS.SOAC - (StreamForm(..), ScremaForm(..), scremaType, getStreamAccums, HistOp(..)) -import qualified Futhark.Representation.SOACS.SOAC as Futhark -import Futhark.Representation.AST - hiding (Var, Iota, Rearrange, Reshape, Replicate, typeOf) -import Futhark.Transform.Substitute -import Futhark.Construct hiding (toExp) -import Futhark.Transform.Rename (renameLambda) -import qualified Futhark.Util.Pretty as PP -import Futhark.Util.Pretty (ppr, text) - --- | A single, simple transformation. If you want several, don't just --- create a list, use 'ArrayTransforms' instead. -data ArrayTransform = Rearrange Certificates [Int] - -- ^ A permutation of an otherwise valid input. - | Reshape Certificates (ShapeChange SubExp) - -- ^ A reshaping of an otherwise valid input. - | ReshapeOuter Certificates (ShapeChange SubExp) - -- ^ A reshaping of the outer dimension. - | ReshapeInner Certificates (ShapeChange SubExp) - -- ^ A reshaping of everything but the outer dimension. - | Replicate Certificates Shape - -- ^ Replicate the rows of the array a number of times. - deriving (Show, Eq, Ord) - -instance Substitute ArrayTransform where - substituteNames substs (Rearrange cs xs) = - Rearrange (substituteNames substs cs) xs - substituteNames substs (Reshape cs ses) = - Reshape (substituteNames substs cs) (substituteNames substs ses) - substituteNames substs (ReshapeOuter cs ses) = - ReshapeOuter (substituteNames substs cs) (substituteNames substs ses) - substituteNames substs (ReshapeInner cs ses) = - ReshapeInner (substituteNames substs cs) (substituteNames substs ses) - substituteNames substs (Replicate cs se) = - Replicate (substituteNames substs cs) (substituteNames substs se) - --- | A sequence of array transformations, heavily inspired by --- "Data.Seq". You can decompose it using 'viewF' and 'viewL', and --- grow it by using '|>' and '<|'. These correspond closely to the --- similar operations for sequences, except that appending will try to --- normalise and simplify the transformation sequence. --- --- The data type is opaque in order to enforce normalisation --- invariants. Basically, when you grow the sequence, the --- implementation will try to coalesce neighboring permutations, for --- example by composing permutations and removing identity --- transformations. -newtype ArrayTransforms = ArrayTransforms (Seq.Seq ArrayTransform) - deriving (Eq, Ord, Show) - -instance Semigroup ArrayTransforms where - ts1 <> ts2 = case viewf ts2 of - t :< ts2' -> (ts1 |> t) <> ts2' - EmptyF -> ts1 - -instance Monoid ArrayTransforms where - mempty = noTransforms - -instance Substitute ArrayTransforms where - substituteNames substs (ArrayTransforms ts) = - ArrayTransforms $ substituteNames substs <$> ts - --- | The empty transformation list. -noTransforms :: ArrayTransforms -noTransforms = ArrayTransforms Seq.empty - --- | Is it an empty transformation list? -nullTransforms :: ArrayTransforms -> Bool -nullTransforms (ArrayTransforms s) = Seq.null s - --- | Decompose the input-end of the transformation sequence. -viewf :: ArrayTransforms -> ViewF -viewf (ArrayTransforms s) = case Seq.viewl s of - t Seq.:< s' -> t :< ArrayTransforms s' - Seq.EmptyL -> EmptyF - --- | A view of the first transformation to be applied. -data ViewF = EmptyF - | ArrayTransform :< ArrayTransforms - --- | Decompose the output-end of the transformation sequence. -viewl :: ArrayTransforms -> ViewL -viewl (ArrayTransforms s) = case Seq.viewr s of - s' Seq.:> t -> ArrayTransforms s' :> t - Seq.EmptyR -> EmptyL - --- | A view of the last transformation to be applied. -data ViewL = EmptyL - | ArrayTransforms :> ArrayTransform - --- | Add a transform to the end of the transformation list. -(|>) :: ArrayTransforms -> ArrayTransform -> ArrayTransforms -(|>) = flip $ addTransform' extract add $ uncurry (flip (,)) - where extract ts' = case viewl ts' of - EmptyL -> Nothing - ts'' :> t' -> Just (t', ts'') - add t' (ArrayTransforms ts') = ArrayTransforms $ ts' Seq.|> t' - --- | Add a transform at the beginning of the transformation list. -(<|) :: ArrayTransform -> ArrayTransforms -> ArrayTransforms -(<|) = addTransform' extract add id - where extract ts' = case viewf ts' of - EmptyF -> Nothing - t' :< ts'' -> Just (t', ts'') - add t' (ArrayTransforms ts') = ArrayTransforms $ t' Seq.<| ts' - -addTransform' :: (ArrayTransforms -> Maybe (ArrayTransform, ArrayTransforms)) - -> (ArrayTransform -> ArrayTransforms -> ArrayTransforms) - -> ((ArrayTransform,ArrayTransform) -> (ArrayTransform,ArrayTransform)) - -> ArrayTransform -> ArrayTransforms - -> ArrayTransforms -addTransform' extract add swap t ts = - fromMaybe (t `add` ts) $ do - (t', ts') <- extract ts - combined <- uncurry combineTransforms $ swap (t', t) - Just $ if identityTransform combined then ts' - else addTransform' extract add swap combined ts' - -identityTransform :: ArrayTransform -> Bool -identityTransform (Rearrange _ perm) = - Foldable.and $ zipWith (==) perm [0..] -identityTransform _ = False - -combineTransforms :: ArrayTransform -> ArrayTransform -> Maybe ArrayTransform -combineTransforms (Rearrange cs2 perm2) (Rearrange cs1 perm1) = - Just $ Rearrange (cs1<>cs2) $ perm2 `rearrangeCompose` perm1 -combineTransforms _ _ = Nothing - --- | Given an expression, determine whether the expression represents --- an input transformation of an array variable. If so, return the --- variable and the transformation. Only 'Rearrange' and 'Reshape' --- are possible to express this way. -transformFromExp :: Certificates -> Exp lore -> Maybe (VName, ArrayTransform) -transformFromExp cs (BasicOp (Futhark.Rearrange perm v)) = - Just (v, Rearrange cs perm) -transformFromExp cs (BasicOp (Futhark.Reshape shape v)) = - Just (v, Reshape cs shape) -transformFromExp cs (BasicOp (Futhark.Replicate shape (Futhark.Var v))) = - Just (v, Replicate cs shape) -transformFromExp _ _ = Nothing - --- | One array input to a SOAC - a SOAC may have multiple inputs, but --- all are of this form. Only the array inputs are expressed with --- this type; other arguments, such as initial accumulator values, are --- plain expressions. The transforms are done left-to-right, that is, --- the first element of the 'ArrayTransform' list is applied first. -data Input = Input ArrayTransforms VName Type - deriving (Show, Eq, Ord) - -instance Substitute Input where - substituteNames substs (Input ts v t) = - Input (substituteNames substs ts) - (substituteNames substs v) (substituteNames substs t) - --- | Create a plain array variable input with no transformations. -varInput :: HasScope t f => VName -> f Input -varInput v = withType <$> lookupType v - where withType = Input (ArrayTransforms Seq.empty) v - --- | Create a plain array variable input with no transformations, from an 'Ident'. -identInput :: Ident -> Input -identInput v = Input (ArrayTransforms Seq.empty) (identName v) (identType v) - --- | If the given input is a plain variable input, with no transforms, --- return the variable. -isVarInput :: Input -> Maybe VName -isVarInput (Input ts v _) | nullTransforms ts = Just v -isVarInput _ = Nothing - --- | If the given input is a plain variable input, with no non-vacuous transforms, --- return the variable. -isVarishInput :: Input -> Maybe VName -isVarishInput (Input ts v t) - | nullTransforms ts = Just v - | Reshape cs [DimCoercion _] :< ts' <- viewf ts, cs == mempty = - isVarishInput $ Input ts' v t -isVarishInput _ = Nothing - --- | Add a transformation to the end of the transformation list. -addTransform :: ArrayTransform -> Input -> Input -addTransform tr (Input trs a t) = - Input (trs |> tr) a t - --- | Add several transformations to the start of the transformation --- list. -addInitialTransforms :: ArrayTransforms -> Input -> Input -addInitialTransforms ts (Input ots a t) = Input (ts <> ots) a t - --- | Convert SOAC inputs to the corresponding expressions. -inputsToSubExps :: (MonadBinder m) => - [Input] -> m [VName] -inputsToSubExps = mapM inputToExp' - where inputToExp' (Input (ArrayTransforms ts) a _) = - foldlM transform a ts - - transform ia (Replicate cs n) = - certifying cs $ - letExp "repeat" $ BasicOp $ Futhark.Replicate n (Futhark.Var ia) - - transform ia (Rearrange cs perm) = - certifying cs $ - letExp "rearrange" $ BasicOp $ Futhark.Rearrange perm ia - - transform ia (Reshape cs shape) = - certifying cs $ - letExp "reshape" $ BasicOp $ Futhark.Reshape shape ia - - transform ia (ReshapeOuter cs shape) = do - shape' <- reshapeOuter shape 1 . arrayShape <$> lookupType ia - certifying cs $ - letExp "reshape_outer" $ BasicOp $ Futhark.Reshape shape' ia - - transform ia (ReshapeInner cs shape) = do - shape' <- reshapeInner shape 1 . arrayShape <$> lookupType ia - certifying cs $ - letExp "reshape_inner" $ BasicOp $ Futhark.Reshape shape' ia - --- | Return the array name of the input. -inputArray :: Input -> VName -inputArray (Input _ v _) = v - --- | Return the type of an input. -inputType :: Input -> Type -inputType (Input (ArrayTransforms ts) _ at) = - Foldable.foldl transformType at ts - where transformType t (Replicate _ shape) = - arrayOfShape t shape - transformType t (Rearrange _ perm) = - rearrangeType perm t - transformType t (Reshape _ shape) = - t `setArrayShape` newShape shape - transformType t (ReshapeOuter _ shape) = - let Shape oldshape = arrayShape t - in t `setArrayShape` Shape (newDims shape ++ drop 1 oldshape) - transformType t (ReshapeInner _ shape) = - let Shape oldshape = arrayShape t - in t `setArrayShape` Shape (take 1 oldshape ++ newDims shape) - --- | Return the row type of an input. Just a convenient alias. -inputRowType :: Input -> Type -inputRowType = rowType . inputType - --- | Return the array rank (dimensionality) of an input. Just a --- convenient alias. -inputRank :: Input -> Int -inputRank = arrayRank . inputType - --- | Apply the transformations to every row of the input. -transformRows :: ArrayTransforms -> Input -> Input -transformRows (ArrayTransforms ts) = - flip (Foldable.foldl transformRows') ts - where transformRows' inp (Rearrange cs perm) = - addTransform (Rearrange cs (0:map (+1) perm)) inp - transformRows' inp (Reshape cs shape) = - addTransform (ReshapeInner cs shape) inp - transformRows' inp (Replicate cs n) - | inputRank inp == 1 = - Rearrange mempty [1,0] `addTransform` - (Replicate cs n `addTransform` inp) - | otherwise = - Rearrange mempty (2:0:1:[3..inputRank inp]) `addTransform` - (Replicate cs n `addTransform` - (Rearrange mempty (1:0:[2..inputRank inp-1]) `addTransform` inp)) - transformRows' inp nts = - error $ "transformRows: Cannot transform this yet:\n" ++ show nts ++ "\n" ++ show inp - --- | Add to the input a 'Rearrange' transform that performs an @(k,n)@ --- transposition. The new transform will be at the end of the current --- transformation list. -transposeInput :: Int -> Int -> Input -> Input -transposeInput k n inp = - addTransform (Rearrange mempty $ transposeIndex k n [0..inputRank inp-1]) inp - --- | A definite representation of a SOAC expression. -data SOAC lore = Stream SubExp (StreamForm lore) (Lambda lore) [Input] - | Scatter SubExp (Lambda lore) [Input] [(SubExp, Int, VName)] - | Screma SubExp (ScremaForm lore) [Input] - | Hist SubExp [HistOp lore] (Lambda lore) [Input] - deriving (Eq, Show) - -instance PP.Pretty Input where - ppr (Input (ArrayTransforms ts) arr _) = foldl f (ppr arr) ts - where f e (Rearrange cs perm) = - text "rearrange" <> ppr cs <> PP.apply [PP.apply (map ppr perm), e] - f e (Reshape cs shape) = - text "reshape" <> ppr cs <> PP.apply [PP.apply (map ppr shape), e] - f e (ReshapeOuter cs shape) = - text "reshape_outer" <> ppr cs <> PP.apply [PP.apply (map ppr shape), e] - f e (ReshapeInner cs shape) = - text "reshape_inner" <> ppr cs <> PP.apply [PP.apply (map ppr shape), e] - f e (Replicate cs ne) = - text "replicate" <> ppr cs <> PP.apply [ppr ne, e] - -instance PrettyLore lore => PP.Pretty (SOAC lore) where - ppr (Screma w form arrs) = Futhark.ppScrema w form arrs - ppr (Hist len ops bucket_fun imgs) = - Futhark.ppHist len ops bucket_fun imgs - ppr soac = text $ show soac - --- | Returns the inputs used in a SOAC. -inputs :: SOAC lore -> [Input] -inputs (Stream _ _ _ arrs) = arrs -inputs (Scatter _len _lam ivs _as) = ivs -inputs (Screma _ _ arrs) = arrs -inputs (Hist _ _ _ inps) = inps - --- | Set the inputs to a SOAC. -setInputs :: [Input] -> SOAC lore -> SOAC lore -setInputs arrs (Stream w form lam _) = - Stream (newWidth arrs w) form lam arrs -setInputs arrs (Scatter w lam _ivs as) = - Scatter (newWidth arrs w) lam arrs as -setInputs arrs (Screma w form _) = - Screma w form arrs -setInputs inps (Hist w ops lam _) = - Hist w ops lam inps - -newWidth :: [Input] -> SubExp -> SubExp -newWidth [] w = w -newWidth (inp:_) _ = arraySize 0 $ inputType inp - --- | The lambda used in a given SOAC. -lambda :: SOAC lore -> Lambda lore -lambda (Stream _ _ lam _) = lam -lambda (Scatter _len lam _ivs _as) = lam -lambda (Screma _ (ScremaForm _ _ lam) _) = lam -lambda (Hist _ _ lam _) = lam - --- | Set the lambda used in the SOAC. -setLambda :: Lambda lore -> SOAC lore -> SOAC lore -setLambda lam (Stream w form _ arrs) = - Stream w form lam arrs -setLambda lam (Scatter len _lam ivs as) = - Scatter len lam ivs as -setLambda lam (Screma w (ScremaForm scan red _) arrs) = - Screma w (ScremaForm scan red lam) arrs -setLambda lam (Hist w ops _ inps) = - Hist w ops lam inps - --- | The return type of a SOAC. -typeOf :: SOAC lore -> [Type] -typeOf (Stream w form lam _) = - let nes = getStreamAccums form - accrtps = take (length nes) $ lambdaReturnType lam - arrtps = [ arrayOf (stripArray 1 t) (Shape [w]) NoUniqueness - | t <- drop (length nes) (lambdaReturnType lam) ] - in accrtps ++ arrtps -typeOf (Scatter _w lam _ivs dests) = - zipWith arrayOfRow (drop (n `div` 2) lam_ts) aws - where lam_ts = lambdaReturnType lam - n = length lam_ts - (aws, _, _) = unzip3 dests -typeOf (Screma w form _) = - scremaType w form -typeOf (Hist _ ops _ _) = do - op <- ops - map (`arrayOfRow` histWidth op) (lambdaReturnType $ histOp op) - --- | The "width" of a SOAC is the expected outer size of its array --- inputs _after_ input-transforms have been carried out. -width :: SOAC lore -> SubExp -width (Stream w _ _ _) = w -width (Scatter len _lam _ivs _as) = len -width (Screma w _ _) = w -width (Hist w _ _ _) = w - --- | Convert a SOAC to the corresponding expression. -toExp :: (MonadBinder m, Op (Lore m) ~ Futhark.SOAC (Lore m)) => - SOAC (Lore m) -> m (Exp (Lore m)) -toExp soac = Op <$> toSOAC soac - --- | Convert a SOAC to a Futhark-level SOAC. -toSOAC :: MonadBinder m => - SOAC (Lore m) -> m (Futhark.SOAC (Lore m)) -toSOAC (Stream w form lam inps) = - Futhark.Stream w form lam <$> inputsToSubExps inps -toSOAC (Scatter len lam ivs dests) = do - ivs' <- inputsToSubExps ivs - return $ Futhark.Scatter len lam ivs' dests -toSOAC (Screma w form arrs) = - Futhark.Screma w form <$> inputsToSubExps arrs -toSOAC (Hist w ops lam inps) = - Futhark.Hist w ops lam <$> inputsToSubExps inps - --- | The reason why some expression cannot be converted to a 'SOAC' --- value. -data NotSOAC = NotSOAC -- ^ The expression is not a (tuple-)SOAC at all. - deriving (Show) - --- | Either convert an expression to the normalised SOAC --- representation, or a reason why the expression does not have the --- valid form. -fromExp :: (Op lore ~ Futhark.SOAC lore, HasScope lore m) => - Exp lore -> m (Either NotSOAC (SOAC lore)) -fromExp (Op (Futhark.Stream w form lam as)) = - Right . Stream w form lam <$> traverse varInput as -fromExp (Op (Futhark.Scatter len lam ivs as)) = - Right <$> (Scatter len lam <$> traverse varInput ivs <*> pure as) -fromExp (Op (Futhark.Screma w form arrs)) = - Right . Screma w form <$> traverse varInput arrs -fromExp (Op (Futhark.Hist w ops lam arrs)) = - Right . Hist w ops lam <$> traverse varInput arrs -fromExp _ = pure $ Left NotSOAC - --- | To-Stream translation of SOACs. --- Returns the Stream SOAC and the --- extra-accumulator body-result ident if any. -soacToStream :: (MonadFreshNames m, Bindable lore, Op lore ~ Futhark.SOAC lore) => - SOAC lore -> m (SOAC lore,[Ident]) -soacToStream soac = do - chunk_param <- newParam "chunk" $ Prim int32 - let chvar= Futhark.Var $ paramName chunk_param - (lam, inps) = (lambda soac, inputs soac) - w = width soac - lam' <- renameLambda lam - let arrrtps= mapType w lam - -- the chunked-outersize of the array result and input types - loutps = [ arrayOfRow t chvar | t <- map rowType arrrtps ] - lintps = [ arrayOfRow t chvar | t <- map inputRowType inps ] - - strm_inpids <- mapM (newParam "inp") lintps - -- Treat each SOAC case individually: - case soac of - Screma _ form _ - | Just _ <- Futhark.isMapSOAC form -> do - -- Map(f,a) => is translated in strem's body to: - -- let strm_resids = map(f,a_ch) in strm_resids - -- - -- array result and input IDs of the stream's lambda - strm_resids <- mapM (newIdent "res") loutps - let insoac = Futhark.Screma chvar (Futhark.mapSOAC lam') $ map paramName strm_inpids - insbnd = mkLet [] strm_resids $ Op insoac - strmbdy= mkBody (oneStm insbnd) $ map (Futhark.Var . identName) strm_resids - strmpar= chunk_param:strm_inpids - strmlam= Lambda strmpar strmbdy loutps - empty_lam = Lambda [] (mkBody mempty []) [] - -- map(f,a) creates a stream with NO accumulators - return (Stream w (Parallel Disorder Commutative empty_lam []) strmlam inps, []) - - | Just (scans, _) <- Futhark.isScanomapSOAC form, - Futhark.Scan scan_lam nes <- Futhark.singleScan scans -> do - -- scanomap(scan_lam,nes,map_lam,a) => is translated in strem's body to: - -- 1. let (scan0_ids,map_resids) = scanomap(scan_lam, nes, map_lam, a_ch) - -- 2. let strm_resids = map (acc `+`,nes, scan0_ids) - -- 3. let outerszm1id = sizeof(0,strm_resids) - 1 - -- 4. let lasteel_ids = if outerszm1id < 0 - -- then nes - -- else strm_resids[outerszm1id] - -- 5. let acc' = acc + lasteel_ids - -- {acc', strm_resids, map_resids} - -- the array and accumulator result types - let scan_arr_ts = map (`arrayOfRow` chvar) $ lambdaReturnType scan_lam - map_arr_ts = drop (length nes) loutps - accrtps = lambdaReturnType scan_lam - - -- array result and input IDs of the stream's lambda - strm_resids <- mapM (newIdent "res") scan_arr_ts - scan0_ids <- mapM (newIdent "resarr0") scan_arr_ts - map_resids <- mapM (newIdent "map_res") map_arr_ts - - lastel_ids <- mapM (newIdent "lstel") accrtps - lastel_tmp_ids <- mapM (newIdent "lstel_tmp") accrtps - empty_arr <- newIdent "empty_arr" $ Prim Bool - inpacc_ids <- mapM (newParam "inpacc") accrtps - outszm1id <- newIdent "szm1" $ Prim int32 - -- 1. let (scan0_ids,map_resids) = scanomap(scan_lam,nes,map_lam,a_ch) - let insbnd = mkLet [] (scan0_ids++map_resids) $ Op $ - Futhark.Screma chvar (Futhark.scanomapSOAC [Futhark.Scan scan_lam nes] lam') $ - map paramName strm_inpids - -- 2. let outerszm1id = chunksize - 1 - outszm1bnd = mkLet [] [outszm1id] $ BasicOp $ - BinOp (Sub Int32 OverflowUndef) - (Futhark.Var $ paramName chunk_param) - (constant (1::Int32)) - -- 3. let lasteel_ids = ... - empty_arr_bnd = mkLet [] [empty_arr] $ BasicOp $ CmpOp (CmpSlt Int32) - (Futhark.Var $ identName outszm1id) - (constant (0::Int32)) - leltmpbnds= zipWith (\ lid arrid -> mkLet [] [lid] $ BasicOp $ - Index (identName arrid) $ - fullSlice (identType arrid) - [DimFix $ Futhark.Var $ identName outszm1id] - ) lastel_tmp_ids scan0_ids - lelbnd = mkLet [] lastel_ids $ - If (Futhark.Var $ identName empty_arr) - (mkBody mempty nes) - (mkBody (stmsFromList leltmpbnds) $ - map (Futhark.Var . identName) lastel_tmp_ids) $ - ifCommon $ map identType lastel_tmp_ids - -- 4. let strm_resids = map (acc `+`,nes, scan0_ids) - maplam <- mkMapPlusAccLam (map (Futhark.Var . paramName) inpacc_ids) scan_lam - let mapbnd = mkLet [] strm_resids $ Op $ - Futhark.Screma chvar (Futhark.mapSOAC maplam) $ - map identName scan0_ids - -- 5. let acc' = acc + lasteel_ids - addlelbdy <- mkPlusBnds scan_lam $ map Futhark.Var $ - map paramName inpacc_ids++map identName lastel_ids - -- Finally, construct the stream - let (addlelbnd,addlelres) = (bodyStms addlelbdy, bodyResult addlelbdy) - strmbdy= mkBody (stmsFromList [insbnd,outszm1bnd,empty_arr_bnd,lelbnd,mapbnd]<>addlelbnd) $ - addlelres ++ map (Futhark.Var . identName) (strm_resids ++ map_resids) - strmpar= chunk_param:inpacc_ids++strm_inpids - strmlam= Lambda strmpar strmbdy (accrtps++loutps) - return (Stream w (Sequential nes) strmlam inps, - map paramIdent inpacc_ids) - - | Just (reds, _) <- Futhark.isRedomapSOAC form, - Futhark.Reduce comm lamin nes <- Futhark.singleReduce reds -> do - -- Redomap(+,lam,nes,a) => is translated in strem's body to: - -- 1. let (acc0_ids,strm_resids) = redomap(+,lam,nes,a_ch) in - -- 2. let acc' = acc + acc0_ids in - -- {acc', strm_resids} - - let accrtps= take (length nes) $ lambdaReturnType lam - -- the chunked-outersize of the array result and input types - loutps' = drop (length nes) loutps - -- the lambda with proper index - foldlam = lam' - -- array result and input IDs of the stream's lambda - strm_resids <- mapM (newIdent "res") loutps' - inpacc_ids <- mapM (newParam "inpacc") accrtps - acc0_ids <- mapM (newIdent "acc0" ) accrtps - -- 1. let (acc0_ids,strm_resids) = redomap(+,lam,nes,a_ch) in - let insoac = Futhark.Screma chvar - (Futhark.redomapSOAC [Futhark.Reduce comm lamin nes] foldlam) $ - map paramName strm_inpids - insbnd = mkLet [] (acc0_ids++strm_resids) $ Op insoac - -- 2. let acc' = acc + acc0_ids in - addaccbdy <- mkPlusBnds lamin $ map Futhark.Var $ - map paramName inpacc_ids++map identName acc0_ids - -- Construct the stream - let (addaccbnd,addaccres) = (bodyStms addaccbdy, bodyResult addaccbdy) - strmbdy= mkBody (oneStm insbnd <> addaccbnd) $ - addaccres ++ map (Futhark.Var . identName) strm_resids - strmpar= chunk_param:inpacc_ids++strm_inpids - strmlam= Lambda strmpar strmbdy (accrtps++loutps') - lam0 <- renameLambda lamin - return (Stream w (Parallel InOrder comm lam0 nes) strmlam inps, []) - - -- Otherwise it cannot become a stream. - _ -> return (soac,[]) - where mkMapPlusAccLam :: (MonadFreshNames m, Bindable lore) - => [SubExp] -> Lambda lore -> m (Lambda lore) - mkMapPlusAccLam accs plus = do - let (accpars, rempars) = splitAt (length accs) $ lambdaParams plus - parbnds = zipWith (\ par se -> mkLet [] [paramIdent par] - (BasicOp $ SubExp se) - ) accpars accs - plus_bdy = lambdaBody plus - newlambdy = Body (bodyAttr plus_bdy) - (stmsFromList parbnds <> bodyStms plus_bdy) - (bodyResult plus_bdy) - renameLambda $ Lambda rempars newlambdy $ lambdaReturnType plus - - mkPlusBnds :: (MonadFreshNames m, Bindable lore) - => Lambda lore -> [SubExp] -> m (Body lore) - mkPlusBnds plus accels = do - plus' <- renameLambda plus - let parbnds = zipWith (\ par se -> mkLet [] [paramIdent par] - (BasicOp $ SubExp se) - ) (lambdaParams plus') accels - body = lambdaBody plus' - return $ body { bodyStms = stmsFromList parbnds <> bodyStms body } diff --git a/src/Futhark/Analysis/Metrics.hs b/src/Futhark/Analysis/Metrics.hs --- a/src/Futhark/Analysis/Metrics.hs +++ b/src/Futhark/Analysis/Metrics.hs @@ -1,7 +1,9 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} --- | Abstract Syntax Tree metrics. This is used in the @futhark-test@ program. +{-# LANGUAGE Trustworthy #-} +-- | Abstract Syntax Tree metrics. This is used in the @futhark test@ +-- program, for the @structure@ stanzas. module Futhark.Analysis.Metrics ( AstMetrics(..) , progMetrics @@ -11,20 +13,20 @@ , seen , inside , MetricsM - , bodyMetrics - , bindingMetrics + , stmMetrics , lambdaMetrics ) where import Control.Monad.Writer import Data.Text (Text) import qualified Data.Text as T -import Data.String import Data.List (tails) import qualified Data.Map.Strict as M -import Futhark.Representation.AST +import Futhark.IR +-- | AST metrics are simply a collection from identifiable node names +-- to the number of times that node appears. newtype AstMetrics = AstMetrics (M.Map Text Int) instance Show AstMetrics where @@ -39,6 +41,7 @@ _ -> Nothing success m = [(AstMetrics $ M.fromList m, "")] +-- | Compute the metrics for some operation. class OpMetrics op where opMetrics :: op -> MetricsM () @@ -60,32 +63,41 @@ [ (T.intercalate "/" (ctx' ++ [k]), 1) | ctx' <- tails $ "" : ctx ] +-- | This monad is used for computing metrics. It internally keeps +-- track of what we've seen so far. Use 'seen' to add more stuff. newtype MetricsM a = MetricsM { runMetricsM :: Writer CountMetrics a } - deriving (Monad, Applicative, Functor, MonadWriter CountMetrics) + deriving (Monad, Applicative, Functor, + MonadWriter CountMetrics) +-- | Add this node to the current tally. seen :: Text -> MetricsM () seen k = tell $ CountMetrics [([], k)] +-- | Enclose a metrics counting operation. Most importantly, this +-- prefixes the name of the context to all the metrics computed in the +-- enclosed operation. inside :: Text -> MetricsM () -> MetricsM () inside what m = seen what >> censor addWhat m where addWhat (CountMetrics metrics) = CountMetrics (map addWhat' metrics) addWhat' (ctx, k) = (what : ctx, k) +-- | Compute the metrics for a program. progMetrics :: OpMetrics (Op lore) => Prog lore -> AstMetrics progMetrics prog = actualMetrics $ execWriter $ runMetricsM $ do mapM_ funDefMetrics $ progFuns prog - mapM_ bindingMetrics $ progConsts prog + mapM_ stmMetrics $ progConsts prog funDefMetrics :: OpMetrics (Op lore) => FunDef lore -> MetricsM () funDefMetrics = bodyMetrics . funDefBody bodyMetrics :: OpMetrics (Op lore) => Body lore -> MetricsM () -bodyMetrics = mapM_ bindingMetrics . bodyStms +bodyMetrics = mapM_ stmMetrics . bodyStms -bindingMetrics :: OpMetrics (Op lore) => Stm lore -> MetricsM () -bindingMetrics = expMetrics . stmExp +-- | Compute metrics for this statement. +stmMetrics :: OpMetrics (Op lore) => Stm lore -> MetricsM () +stmMetrics = expMetrics . stmExp expMetrics :: OpMetrics (Op lore) => Exp lore -> MetricsM () expMetrics (BasicOp op) = @@ -98,8 +110,8 @@ inside "If" $ do inside "True" $ bodyMetrics tb inside "False" $ bodyMetrics fb -expMetrics (Apply fname _ _ _) = - seen $ "Apply" <> fromString (nameToString fname) +expMetrics Apply{} = + seen "Apply" expMetrics (Op op) = opMetrics op @@ -125,5 +137,6 @@ primOpMetrics Rearrange{} = seen "Rearrange" primOpMetrics Rotate{} = seen "Rotate" +-- | Compute metrics for this lambda. lambdaMetrics :: OpMetrics (Op lore) => Lambda lore -> MetricsM () lambdaMetrics = bodyMetrics . lambdaBody diff --git a/src/Futhark/Analysis/PrimExp.hs b/src/Futhark/Analysis/PrimExp.hs --- a/src/Futhark/Analysis/PrimExp.hs +++ b/src/Futhark/Analysis/PrimExp.hs @@ -12,7 +12,7 @@ , false , constFoldPrimExp - , module Futhark.Representation.Primitive + , module Futhark.IR.Primitive , (.&&.), (.||.), (.<.), (.<=.), (.>.), (.>=.), (.==.), (.&.), (.|.), (.^.) ) where @@ -21,8 +21,8 @@ import qualified Data.Map as M import qualified Data.Set as S -import Futhark.Representation.AST.Attributes.Names -import Futhark.Representation.Primitive +import Futhark.IR.Prop.Names +import Futhark.IR.Primitive import Futhark.Util.IntegralExp import Futhark.Util.Pretty @@ -358,6 +358,8 @@ ppr (UnOpExp op x) = ppr op <+> parens (ppr x) ppr (FunExp h args _) = text h <+> parens (commasep $ map ppr args) +-- | Produce a mapping from the leaves of the 'PrimExp' to their +-- designated types. leafExpTypes :: Ord a => PrimExp a -> S.Set (a, PrimType) leafExpTypes (LeafExp x ptp) = S.singleton (x, ptp) leafExpTypes (ValueExp _) = S.empty diff --git a/src/Futhark/Analysis/PrimExp/Convert.hs b/src/Futhark/Analysis/PrimExp/Convert.hs --- a/src/Futhark/Analysis/PrimExp/Convert.hs +++ b/src/Futhark/Analysis/PrimExp/Convert.hs @@ -1,10 +1,9 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} --- | Converting back and forth between 'PrimExp's. +-- | Converting back and forth between 'PrimExp's. Use the 'ToExp' +-- instance to convert to Futhark expressions. module Futhark.Analysis.PrimExp.Convert ( - primExpToExp - , primExpFromExp - , primExpToSubExp + primExpFromExp , primExpFromSubExp , primExpFromSubExpM , replaceInPrimExp @@ -17,51 +16,36 @@ import qualified Control.Monad.Fail as Fail import Control.Monad.Identity -import Data.Loc import qualified Data.Map.Strict as M import Data.Maybe import Futhark.Analysis.PrimExp import Futhark.Construct -import Futhark.Representation.AST - --- | Convert a 'PrimExp' to a Futhark expression. The provided --- function converts the leaves. -primExpToExp :: MonadBinder m => - (v -> m (Exp (Lore m))) -> PrimExp v -> m (Exp (Lore m)) -primExpToExp f (BinOpExp op x y) = - BasicOp <$> (BinOp op - <$> primExpToSubExp "binop_x" f x - <*> primExpToSubExp "binop_y" f y) -primExpToExp f (CmpOpExp op x y) = - BasicOp <$> (CmpOp op - <$> primExpToSubExp "cmpop_x" f x - <*> primExpToSubExp "cmpop_y" f y) -primExpToExp f (UnOpExp op x) = - BasicOp <$> (UnOp op <$> primExpToSubExp "unop_x" f x) -primExpToExp f (ConvOpExp op x) = - BasicOp <$> (ConvOp op <$> primExpToSubExp "convop_x" f x) -primExpToExp _ (ValueExp v) = - return $ BasicOp $ SubExp $ Constant v -primExpToExp f (FunExp h args t) = - Apply (nameFromString h) <$> args' <*> pure [primRetType t] <*> - pure (Safe, noLoc, []) - where args' = zip <$> mapM (primExpToSubExp "apply_arg" f) args <*> pure (repeat Observe) -primExpToExp f (LeafExp v _) = - f v +import Futhark.IR instance ToExp v => ToExp (PrimExp v) where - toExp = primExpToExp toExp - -primExpToSubExp :: MonadBinder m => - String -> (v -> m (Exp (Lore m))) -> PrimExp v -> m SubExp -primExpToSubExp s f e = letSubExp s =<< primExpToExp f e + toExp (BinOpExp op x y) = + BasicOp <$> (BinOp op <$> toSubExp "binop_x" x <*> toSubExp "binop_y" y) + toExp (CmpOpExp op x y) = + BasicOp <$> (CmpOp op <$> toSubExp "cmpop_x" x <*> toSubExp "cmpop_y" y) + toExp (UnOpExp op x) = + BasicOp <$> (UnOp op <$> toSubExp "unop_x" x) + toExp (ConvOpExp op x) = + BasicOp <$> (ConvOp op <$> toSubExp "convop_x" x) + toExp (ValueExp v) = + return $ BasicOp $ SubExp $ Constant v + toExp (FunExp h args t) = + Apply (nameFromString h) <$> args' <*> pure [primRetType t] <*> + pure (Safe, mempty, []) + where args' = zip <$> mapM (toSubExp "apply_arg") args <*> pure (repeat Observe) + toExp (LeafExp v _) = + toExp v -- | Convert an expression to a 'PrimExp'. The provided function is -- used to convert expressions that are not trivially 'PrimExp's. -- This includes constants and variable names, which are passed as --- 'SubExp's. -primExpFromExp :: (Fail.MonadFail m, Annotations lore) => +-- t'SubExp's. +primExpFromExp :: (Fail.MonadFail m, Decorations lore) => (VName -> m (PrimExp v)) -> Exp lore -> m (PrimExp v) primExpFromExp f (BasicOp (BinOp op x y)) = BinOpExp op <$> primExpFromSubExpM f x <*> primExpFromSubExpM f y @@ -71,18 +55,19 @@ UnOpExp op <$> primExpFromSubExpM f x primExpFromExp f (BasicOp (ConvOp op x)) = ConvOpExp op <$> primExpFromSubExpM f x -primExpFromExp _ (BasicOp (SubExp (Constant v))) = - return $ ValueExp v +primExpFromExp f (BasicOp (SubExp se)) = + primExpFromSubExpM f se primExpFromExp f (Apply fname args ts _) - | isBuiltInFunction fname, [Prim t] <- retTypeValues ts = + | isBuiltInFunction fname, [Prim t] <- map declExtTypeOf ts = FunExp (nameToString fname) <$> mapM (primExpFromSubExpM f . fst) args <*> pure t primExpFromExp _ _ = fail "Not a PrimExp" +-- | Like 'primExpFromExp', but for a t'SubExp'. primExpFromSubExpM :: Applicative m => (VName -> m (PrimExp v)) -> SubExp -> m (PrimExp v) primExpFromSubExpM f (Var v) = f v primExpFromSubExpM _ (Constant v) = pure $ ValueExp v --- | Convert 'SubExp's of a given type. +-- | Convert t'SubExp's of a given type. primExpFromSubExp :: PrimType -> SubExp -> PrimExp VName primExpFromSubExp t (Var v) = LeafExp v t primExpFromSubExp _ (Constant v) = ValueExp v @@ -107,6 +92,7 @@ replaceInPrimExpM f (FunExp h args t) = FunExp h <$> mapM (replaceInPrimExpM f) args <*> pure t +-- | As 'replaceInPrimExpM', but in the identity monad. replaceInPrimExp :: (a -> PrimType -> PrimExp b) -> PrimExp a -> PrimExp b replaceInPrimExp f e = runIdentity $ replaceInPrimExpM f' e diff --git a/src/Futhark/Analysis/PrimExp/Generalize.hs b/src/Futhark/Analysis/PrimExp/Generalize.hs --- a/src/Futhark/Analysis/PrimExp/Generalize.hs +++ b/src/Futhark/Analysis/PrimExp/Generalize.hs @@ -1,3 +1,4 @@ +-- | Generalization (anti-unification) of 'PrimExp's. module Futhark.Analysis.PrimExp.Generalize ( leastGeneralGeneralization @@ -8,10 +9,9 @@ import Futhark.Analysis.PrimExp -import Futhark.Representation.AST.Syntax.Core (Ext(..)) +import Futhark.IR.Syntax.Core (Ext(..)) --- | Generalization (anti-unification) --- We assume that the two expressions have the same type. +-- | Generalize two 'PrimExp's of the the same type. leastGeneralGeneralization :: (Eq v) => [(PrimExp v, PrimExp v)] -> PrimExp v -> PrimExp v -> Maybe (PrimExp (Ext v), [(PrimExp v, PrimExp v)]) leastGeneralGeneralization m exp1@(LeafExp v1 t1) exp2@(LeafExp v2 _) = diff --git a/src/Futhark/Analysis/PrimExp/Simplify.hs b/src/Futhark/Analysis/PrimExp/Simplify.hs --- a/src/Futhark/Analysis/PrimExp/Simplify.hs +++ b/src/Futhark/Analysis/PrimExp/Simplify.hs @@ -6,7 +6,7 @@ import Futhark.Analysis.PrimExp import Futhark.Optimise.Simplify.Engine as Engine -import Futhark.Representation.AST +import Futhark.IR -- | Simplify a 'PrimExp', including copy propagation. If a 'LeafExp' -- refers to a name that is a 'Constant', the node turns into a diff --git a/src/Futhark/Analysis/Range.hs b/src/Futhark/Analysis/Range.hs --- a/src/Futhark/Analysis/Range.hs +++ b/src/Futhark/Analysis/Range.hs @@ -1,12 +1,10 @@ {-# LANGUAGE FlexibleContexts #-} +-- | Perform range analysis of a program or other fragment. module Futhark.Analysis.Range ( rangeAnalysis , runRangeM , RangeM - , analyseFun - , analyseExp , analyseLambda - , analyseBody , analyseStms ) where @@ -16,34 +14,37 @@ import Data.List (nub) import qualified Futhark.Analysis.ScalExp as SE -import Futhark.Representation.Ranges +import Futhark.IR.Ranges import Futhark.Analysis.AlgSimplify as AS -- Entry point -- | Perform variable range analysis on the given program, returning a -- program with embedded range annotations. -rangeAnalysis :: (Attributes lore, CanBeRanged (Op lore)) => +rangeAnalysis :: (ASTLore lore, CanBeRanged (Op lore)) => Prog lore -> Prog (Ranges lore) rangeAnalysis (Prog consts funs) = Prog (runRangeM $ mapM analyseStm consts) (map analyseFun funs) -- Implementation -analyseFun :: (Attributes lore, CanBeRanged (Op lore)) => +analyseFun :: (ASTLore lore, CanBeRanged (Op lore)) => FunDef lore -> FunDef (Ranges lore) analyseFun (FunDef entry fname restype params body) = runRangeM $ bindFunParams params $ FunDef entry fname restype params <$> analyseBody body -analyseBody :: (Attributes lore, CanBeRanged (Op lore)) => +analyseBody :: (ASTLore lore, CanBeRanged (Op lore)) => Body lore -> RangeM (Body (Ranges lore)) analyseBody (Body lore origbnds result) = analyseStms origbnds $ \bnds' -> return $ mkRangedBody lore bnds' result -analyseStms :: (Attributes lore, CanBeRanged (Op lore)) => +-- | Perform range analysis on some statements, taking a continuation +-- where the ranges of the variables bound by the statements is +-- in scope. +analyseStms :: (ASTLore lore, CanBeRanged (Op lore)) => Stms lore -> (Stms (Ranges lore) -> RangeM a) -> RangeM a @@ -55,14 +56,14 @@ bindPattern (stmPattern bnd') $ analyseStms' (acc <> oneStm bnd') bnds m -analyseStm :: (Attributes lore, CanBeRanged (Op lore)) => +analyseStm :: (ASTLore lore, CanBeRanged (Op lore)) => Stm lore -> RangeM (Stm (Ranges lore)) analyseStm (Let pat lore e) = do e' <- analyseExp e pat' <- simplifyPatRanges $ addRangesToPattern pat e' return $ Let pat' lore e' -analyseExp :: (Attributes lore, CanBeRanged (Op lore)) => +analyseExp :: (ASTLore lore, CanBeRanged (Op lore)) => Exp lore -> RangeM (Exp (Ranges lore)) analyseExp = mapExpM analyse @@ -77,7 +78,8 @@ , mapOnOp = return . addOpRanges } -analyseLambda :: (Attributes lore, CanBeRanged (Op lore)) => +-- | Perform range analysis on a lambda. +analyseLambda :: (ASTLore lore, CanBeRanged (Op lore)) => Lambda lore -> RangeM (Lambda (Ranges lore)) analyseLambda lam = do @@ -93,12 +95,14 @@ emptyRangeEnv :: RangeEnv emptyRangeEnv = M.empty +-- | The range analysis monad. type RangeM = Reader RangeEnv +-- | Run a 'RangeM' action. runRangeM :: RangeM a -> a runRangeM = flip runReader emptyRangeEnv -bindFunParams :: Typed attr => [Param attr] -> RangeM a -> RangeM a +bindFunParams :: Typed dec => [Param dec] -> RangeM a -> RangeM a bindFunParams [] m = m bindFunParams (param:params) m = do @@ -109,7 +113,7 @@ where bindFunParam = M.insert (paramName param) unknownRange dims = arrayDims $ paramType param -bindPattern :: Typed attr => PatternT (Range, attr) -> RangeM a -> RangeM a +bindPattern :: Typed dec => PatternT (Range, dec) -> RangeM a -> RangeM a bindPattern pat m = do ranges <- rangesRep local bindPatElems $ @@ -118,7 +122,7 @@ where bindPatElems env = foldl bindPatElem env $ patternElements pat bindPatElem env patElem = - M.insert (patElemName patElem) (fst $ patElemAttr patElem) env + M.insert (patElemName patElem) (fst $ patElemDec patElem) env dims = nub $ concatMap arrayDims $ patternTypes pat refineDimensionRanges :: AS.RangesRep -> [SubExp] @@ -155,14 +159,14 @@ lookupRange :: VName -> RangeM Range lookupRange = asks . M.findWithDefault unknownRange -simplifyPatRanges :: PatternT (Range, attr) - -> RangeM (PatternT (Range, attr)) +simplifyPatRanges :: PatternT (Range, dec) + -> RangeM (PatternT (Range, dec)) simplifyPatRanges (Pattern context values) = Pattern <$> mapM simplifyPatElemRange context <*> mapM simplifyPatElemRange values where simplifyPatElemRange patElem = do - let (range, innerattr) = patElemAttr patElem + let (range, innerdec) = patElemDec patElem range' <- simplifyRange range - return $ setPatElemLore patElem (range', innerattr) + return $ setPatElemLore patElem (range', innerdec) simplifyRange :: Range -> RangeM Range simplifyRange (lower, upper) = do diff --git a/src/Futhark/Analysis/Rephrase.hs b/src/Futhark/Analysis/Rephrase.hs --- a/src/Futhark/Analysis/Rephrase.hs +++ b/src/Futhark/Analysis/Rephrase.hs @@ -1,6 +1,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE ConstraintKinds #-} --- | Facilities for changing the lore of some fragment, with no context. +-- | Facilities for changing the lore of some fragment, with no +-- context. We call this "rephrasing", for no deep reason. module Futhark.Analysis.Rephrase ( rephraseProg , rephraseFunDef @@ -14,25 +15,32 @@ ) where -import Futhark.Representation.AST +import Futhark.IR +-- | A collection of functions that together allow us to rephrase some +-- IR fragment, in some monad @m@. If we let @m@ be the 'Maybe' +-- monad, we can conveniently do rephrasing that might fail. This is +-- useful if you want to see if some IR in e.g. the @Kernels@ lore +-- actually uses any @Kernels@-specific operations. data Rephraser m from to - = Rephraser { rephraseExpLore :: ExpAttr from -> m (ExpAttr to) - , rephraseLetBoundLore :: LetAttr from -> m (LetAttr to) - , rephraseFParamLore :: FParamAttr from -> m (FParamAttr to) - , rephraseLParamLore :: LParamAttr from -> m (LParamAttr to) - , rephraseBodyLore :: BodyAttr from -> m (BodyAttr to) + = Rephraser { rephraseExpLore :: ExpDec from -> m (ExpDec to) + , rephraseLetBoundLore :: LetDec from -> m (LetDec to) + , rephraseFParamLore :: FParamInfo from -> m (FParamInfo to) + , rephraseLParamLore :: LParamInfo from -> m (LParamInfo to) + , rephraseBodyLore :: BodyDec from -> m (BodyDec to) , rephraseRetType :: RetType from -> m (RetType to) , rephraseBranchType :: BranchType from -> m (BranchType to) , rephraseOp :: Op from -> m (Op to) } +-- | Rephrase an entire program. rephraseProg :: Monad m => Rephraser m from to -> Prog from -> m (Prog to) rephraseProg rephraser (Prog consts funs) = Prog <$> mapM (rephraseStm rephraser) consts <*> mapM (rephraseFunDef rephraser) funs +-- | Rephrase a function definition. rephraseFunDef :: Monad m => Rephraser m from to -> FunDef from -> m (FunDef to) rephraseFunDef rephraser fundec = do body' <- rephraseBody rephraser $ funDefBody fundec @@ -40,32 +48,36 @@ rettype' <- mapM (rephraseRetType rephraser) $ funDefRetType fundec return fundec { funDefBody = body', funDefParams = params', funDefRetType = rettype' } +-- | Rephrase an expression. rephraseExp :: Monad m => Rephraser m from to -> Exp from -> m (Exp to) rephraseExp = mapExpM . mapper +-- | Rephrase a statement. rephraseStm :: Monad m => Rephraser m from to -> Stm from -> m (Stm to) -rephraseStm rephraser (Let pat (StmAux cs attr) e) = +rephraseStm rephraser (Let pat (StmAux cs attrs dec) e) = Let <$> rephrasePattern (rephraseLetBoundLore rephraser) pat <*> - (StmAux cs <$> rephraseExpLore rephraser attr) <*> + (StmAux cs attrs <$> rephraseExpLore rephraser dec) <*> rephraseExp rephraser e +-- | Rephrase a pattern. rephrasePattern :: Monad m => (from -> m to) -> PatternT from -> m (PatternT to) -rephrasePattern f (Pattern context values) = - Pattern <$> rephrase context <*> rephrase values - where rephrase = mapM $ rephrasePatElem f +rephrasePattern = traverse +-- | Rephrase a pattern element. rephrasePatElem :: Monad m => (from -> m to) -> PatElemT from -> m (PatElemT to) rephrasePatElem rephraser (PatElem ident from) = PatElem ident <$> rephraser from +-- | Rephrase a parameter. rephraseParam :: Monad m => (from -> m to) -> Param from -> m (Param to) rephraseParam rephraser (Param name from) = Param name <$> rephraser from +-- | Rephrase a body. rephraseBody :: Monad m => Rephraser m from to -> Body from -> m (Body to) rephraseBody rephraser (Body lore bnds res) = Body <$> @@ -73,6 +85,7 @@ (stmsFromList <$> mapM (rephraseStm rephraser) (stmsToList bnds)) <*> pure res +-- | Rephrase a lambda. rephraseLambda :: Monad m => Rephraser m from to -> Lambda from -> m (Lambda to) rephraseLambda rephraser lam = do body' <- rephraseBody rephraser $ lambdaBody lam diff --git a/src/Futhark/Analysis/ScalExp.hs b/src/Futhark/Analysis/ScalExp.hs --- a/src/Futhark/Analysis/ScalExp.hs +++ b/src/Futhark/Analysis/ScalExp.hs @@ -1,4 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} +-- | A legacy representation of scalar expressions used solely for +-- algebraic simplification. Never use this. Use +-- "Futhark.Analysis.PrimExp" instead. module Futhark.Analysis.ScalExp ( RelOp0(..) , ScalExp(..) @@ -8,16 +11,16 @@ , toScalExp , expandScalExp , LookupVar - , module Futhark.Representation.Primitive + , module Futhark.IR.Primitive ) where import Data.List (find) import Data.Maybe -import Futhark.Representation.Primitive hiding (SQuot, SRem, SDiv, SMod, SSignum) -import Futhark.Representation.AST hiding (SQuot, SRem, SDiv, SMod, SSignum) -import qualified Futhark.Representation.AST as AST +import Futhark.IR.Primitive hiding (SQuot, SRem, SDiv, SMod, SSignum) +import Futhark.IR hiding (SQuot, SRem, SDiv, SMod, SSignum) +import qualified Futhark.IR as AST import Futhark.Transform.Substitute import Futhark.Transform.Rename import Futhark.Util.Pretty hiding (pretty) @@ -133,6 +136,7 @@ instance Rename ScalExp where rename = substituteRename +-- | The type of a scalar expression. scalExpType :: ScalExp -> PrimType scalExpType (Val v) = primValueType v scalExpType (Id _ t) = t @@ -186,6 +190,7 @@ subExpToScalExp (Var v) t = Id v t subExpToScalExp (Constant val) _ = Val val +-- | Recursively convert an expression to a scalar expression. toScalExp :: (HasScope t f, Monad f) => LookupVar -> Exp lore -> f (Maybe ScalExp) toScalExp look (BasicOp (SubExp (Var v))) diff --git a/src/Futhark/Analysis/SymbolTable.hs b/src/Futhark/Analysis/SymbolTable.hs --- a/src/Futhark/Analysis/SymbolTable.hs +++ b/src/Futhark/Analysis/SymbolTable.hs @@ -13,7 +13,7 @@ , bindingDepth , valueRange , entryStm - , entryLetBoundAttr + , entryLetBoundDec , entryType , asScalExp -- * Lookup @@ -65,15 +65,15 @@ import Prelude hiding (elem, lookup) import Futhark.Analysis.PrimExp.Convert -import Futhark.Representation.AST hiding (FParam, lookupType) -import qualified Futhark.Representation.AST as AST +import Futhark.IR hiding (FParam, lookupType) +import qualified Futhark.IR as AST import Futhark.Analysis.ScalExp import qualified Futhark.Analysis.AlgSimplify as AS -import Futhark.Representation.AST.Attributes.Ranges +import Futhark.IR.Prop.Ranges (Range, ScalExpRange, Ranged) -import qualified Futhark.Representation.AST.Attributes.Ranges as Ranges -import qualified Futhark.Representation.AST.Attributes.Aliases as Aliases +import qualified Futhark.IR.Prop.Ranges as Ranges +import qualified Futhark.IR.Prop.Aliases as Aliases data SymbolTable lore = SymbolTable { loopDepth :: Int @@ -102,9 +102,9 @@ empty :: SymbolTable lore empty = SymbolTable 0 M.empty mempty False -fromScope :: Attributes lore => Scope lore -> SymbolTable lore +fromScope :: ASTLore lore => Scope lore -> SymbolTable lore fromScope = M.foldlWithKey' insertFreeVar' empty - where insertFreeVar' m k attr = insertFreeVar k attr m + where insertFreeVar' m k dec = insertFreeVar k dec m toScope :: SymbolTable lore -> Scope lore toScope = M.map entryInfo . bindings @@ -147,7 +147,7 @@ data LetBoundEntry lore = LetBoundEntry { letBoundRange :: ScalExpRange - , letBoundAttr :: LetAttr lore + , letBoundDec :: LetDec lore , letBoundAliases :: Names , letBoundStm :: Stm lore , letBoundStmDepth :: Int @@ -160,7 +160,7 @@ data FParamEntry lore = FParamEntry { fparamRange :: ScalExpRange - , fparamAttr :: FParamAttr lore + , fparamDec :: FParamInfo lore , fparamAliases :: Names , fparamStmDepth :: Int , fparamConsumed :: Bool @@ -168,14 +168,14 @@ data LParamEntry lore = LParamEntry { lparamRange :: ScalExpRange - , lparamAttr :: LParamAttr lore + , lparamDec :: LParamInfo lore , lparamStmDepth :: Int , lparamIndex :: IndexArray , lparamConsumed :: Bool } data FreeVarEntry lore = - FreeVarEntry { freeVarAttr :: NameInfo lore + FreeVarEntry { freeVarDec :: NameInfo lore , freeVarStmDepth :: Int , freeVarRange :: ScalExpRange , freeVarIndex :: VName -> IndexArray @@ -185,13 +185,13 @@ } entryInfo :: Entry lore -> NameInfo lore -entryInfo (LetBound entry) = LetInfo $ letBoundAttr entry -entryInfo (LoopVar entry) = IndexInfo $ loopVarType entry -entryInfo (FParam entry) = FParamInfo $ fparamAttr entry -entryInfo (LParam entry) = LParamInfo $ lparamAttr entry -entryInfo (FreeVar entry) = freeVarAttr entry +entryInfo (LetBound entry) = LetName $ letBoundDec entry +entryInfo (LoopVar entry) = IndexName $ loopVarType entry +entryInfo (FParam entry) = FParamName $ fparamDec entry +entryInfo (LParam entry) = LParamName $ lparamDec entry +entryInfo (FreeVar entry) = freeVarDec entry -entryType :: Attributes lore => Entry lore -> Type +entryType :: ASTLore lore => Entry lore -> Type entryType = typeOf . entryInfo isVarBound :: Entry lore -> Maybe (LetBoundEntry lore) @@ -250,9 +250,9 @@ entryStm (LetBound entry) = Just $ letBoundStm entry entryStm _ = Nothing -entryLetBoundAttr :: Entry lore -> Maybe (LetAttr lore) -entryLetBoundAttr (LetBound entry) = Just $ letBoundAttr entry -entryLetBoundAttr _ = Nothing +entryLetBoundDec :: Entry lore -> Maybe (LetDec lore) +entryLetBoundDec (LetBound entry) = Just $ letBoundDec entry +entryLetBoundDec _ = Nothing asStm :: Entry lore -> Maybe (Stm lore) asStm = fmap letBoundStm . isVarBound @@ -274,10 +274,10 @@ Just (BasicOp e, cs) -> Just (e, cs) _ -> Nothing -lookupType :: Attributes lore => VName -> SymbolTable lore -> Maybe Type +lookupType :: ASTLore lore => VName -> SymbolTable lore -> Maybe Type lookupType name vtable = entryType <$> lookup name vtable -lookupSubExpType :: Attributes lore => SubExp -> SymbolTable lore -> Maybe Type +lookupSubExpType :: ASTLore lore => SubExp -> SymbolTable lore -> Maybe Type lookupSubExpType (Var v) = lookupType v lookupSubExpType (Constant v) = const $ Just $ Prim $ primValueType v @@ -288,7 +288,7 @@ BasicOp (SubExp se) -> Just (se,cs) _ -> Nothing -lookupScalExp :: Attributes lore => VName -> SymbolTable lore -> Maybe ScalExp +lookupScalExp :: ASTLore lore => VName -> SymbolTable lore -> Maybe ScalExp lookupScalExp name vtable = case (lookup name vtable, lookupRange name vtable) of -- If we know the lower and upper bound, and these are the same, @@ -311,7 +311,7 @@ available :: VName -> SymbolTable lore -> Bool available name = maybe False (not . consumed) . M.lookup name . bindings -index :: Attributes lore => VName -> [SubExp] -> SymbolTable lore +index :: ASTLore lore => VName -> [SubExp] -> SymbolTable lore -> Maybe Indexed index name is table = do is' <- mapM asPrimExp is @@ -345,14 +345,14 @@ knownRange (_, lower, upper) = isJust lower || isJust upper class IndexOp op where - indexOp :: (Attributes lore, IndexOp (Op lore)) => + indexOp :: (ASTLore lore, IndexOp (Op lore)) => SymbolTable lore -> Int -> op -> [PrimExp VName] -> Maybe Indexed indexOp _ _ _ _ = Nothing instance IndexOp () where -indexExp :: (IndexOp (Op lore), Attributes lore) => +indexExp :: (IndexOp (Op lore), ASTLore lore) => SymbolTable lore -> Exp lore -> Int -> IndexArray indexExp vtable (Op op) k is = @@ -395,7 +395,7 @@ indexExp _ _ _ _ = Nothing -defBndEntry :: (Attributes lore, IndexOp (Op lore)) => +defBndEntry :: (ASTLore lore, IndexOp (Op lore)) => SymbolTable lore -> PatElem lore -> Range @@ -405,7 +405,7 @@ defBndEntry vtable patElem range als bnd = LetBoundEntry { letBoundRange = simplifyRange $ scalExpRange range - , letBoundAttr = patElemAttr patElem + , letBoundDec = patElemDec patElem , letBoundAliases = als , letBoundStm = bnd , letBoundScalExp = @@ -459,13 +459,13 @@ return $ defBndEntry vtable pat_elem (Ranges.rangeOf pat_elem) (Aliases.aliasesOf pat_elem) bnd -insertEntry :: Attributes lore => +insertEntry :: ASTLore lore => VName -> Entry lore -> SymbolTable lore -> SymbolTable lore insertEntry name entry = insertEntries [(name,entry)] -insertEntries :: Attributes lore => +insertEntries :: ASTLore lore => [(VName, Entry lore)] -> SymbolTable lore -> SymbolTable lore insertEntries entries vtable = @@ -509,27 +509,27 @@ where aliasesOfAliases = mconcat . map (`lookupAliases` vtable) . namesToList $ names -insertFParam :: Attributes lore => +insertFParam :: ASTLore lore => AST.FParam lore -> SymbolTable lore -> SymbolTable lore insertFParam fparam = flip (foldr (`isAtLeast` 0)) sizes . insertEntry name entry where name = AST.paramName fparam entry = FParam FParamEntry { fparamRange = (Nothing, Nothing) - , fparamAttr = AST.paramAttr fparam + , fparamDec = AST.paramDec fparam , fparamAliases = mempty , fparamStmDepth = 0 , fparamConsumed = False } sizes = subExpVars $ arrayDims $ AST.paramType fparam -insertFParams :: Attributes lore => +insertFParams :: ASTLore lore => [AST.FParam lore] -> SymbolTable lore -> SymbolTable lore insertFParams fparams symtable = foldl' (flip insertFParam) symtable fparams -insertLParamWithRange :: Attributes lore => +insertLParamWithRange :: ASTLore lore => LParam lore -> ScalExpRange -> IndexArray -> SymbolTable lore -> SymbolTable lore insertLParamWithRange param range indexf vtable = @@ -538,7 +538,7 @@ let vtable' = insertEntry name bind vtable in foldr (`isAtLeast` 0) vtable' sizevars where bind = LParam LParamEntry { lparamRange = range - , lparamAttr = AST.paramAttr param + , lparamDec = AST.paramDec param , lparamStmDepth = 0 , lparamIndex = indexf , lparamConsumed = False @@ -546,12 +546,12 @@ name = AST.paramName param sizevars = subExpVars $ arrayDims $ AST.paramType param -insertLParam :: Attributes lore => +insertLParam :: ASTLore lore => LParam lore -> SymbolTable lore -> SymbolTable lore insertLParam param = insertLParamWithRange param (Nothing, Nothing) (const Nothing) -insertArrayLParam :: Attributes lore => +insertArrayLParam :: ASTLore lore => LParam lore -> Maybe VName -> SymbolTable lore -> SymbolTable lore insertArrayLParam param (Just array) vtable = @@ -566,7 +566,7 @@ -- Well, we still know that it's a param... insertLParam param vtable -insertLoopVar :: Attributes lore => VName -> IntType -> SubExp -> SymbolTable lore -> SymbolTable lore +insertLoopVar :: ASTLore lore => VName -> IntType -> SubExp -> SymbolTable lore -> SymbolTable lore insertLoopVar name it bound = insertEntry name bind where bind = LoopVar LoopVarEntry { loopVarRange = (Just 0, @@ -575,17 +575,17 @@ , loopVarType = it } -insertFreeVar :: Attributes lore => VName -> NameInfo lore -> SymbolTable lore -> SymbolTable lore -insertFreeVar name attr = insertEntry name entry +insertFreeVar :: ASTLore lore => VName -> NameInfo lore -> SymbolTable lore -> SymbolTable lore +insertFreeVar name dec = insertEntry name entry where entry = FreeVar FreeVarEntry { - freeVarAttr = attr + freeVarDec = dec , freeVarRange = (Nothing, Nothing) , freeVarStmDepth = 0 , freeVarIndex = \_ _ -> Nothing , freeVarConsumed = False } -updateBounds :: Attributes lore => Bool -> SubExp -> SymbolTable lore -> SymbolTable lore +updateBounds :: ASTLore lore => Bool -> SubExp -> SymbolTable lore -> SymbolTable lore updateBounds isTrue cond vtable = case runReader (toScalExp (`lookupScalExp` vtable) $ BasicOp $ SubExp cond) types of Nothing -> vtable @@ -602,7 +602,7 @@ -- | Refines the ranges in the symbol table with -- ranges extracted from branch conditions. --- `cond' is the condition of the if-branch. +-- @cond@ is the condition of the if-branch. updateBounds' :: ScalExp -> SymbolTable lore -> SymbolTable lore updateBounds' _ sym_tab | noUpdateBounds = sym_tab updateBounds' cond sym_tab = @@ -617,12 +617,12 @@ where (lower, upper) = valueRange entry nonEmptyRange (_, lower, upper) = isJust lower || isJust upper - -- | Input: a bool exp in DNF form, named `cond' + -- | Input: a bool exp in DNF form, named @cond@ -- It gets the terms of the argument, -- i.e., cond = c1 || ... || cn -- and negates them. -- Returns [not c1, ..., not cn], i.e., the factors - -- of `not cond' in CNF form: not cond = (not c1) && ... && (not cn) + -- of @not cond@ in CNF form: not cond = (not c1) && ... && (not cn) getNotFactorsLEQ0 :: ScalExp -> [ScalExp] getNotFactorsLEQ0 (RelExp rel e_scal) = if scalExpType e_scal /= int32 then [] @@ -634,11 +634,11 @@ getNotFactorsLEQ0 (SLogOr e1 e2) = getNotFactorsLEQ0 e1 ++ getNotFactorsLEQ0 e2 getNotFactorsLEQ0 _ = [] - -- | Argument is scalar expression `e'. + -- | Argument is scalar expression @e@. -- Implementation finds the symbol defined at - -- the highest depth in expression `e', call it `i', - -- and decomposes e = a*i + b. If `a' and `b' are - -- free of `i', AND `a == 1 or -1' THEN the upper/lower + -- the highest depth in expression @e@, call it @i@, + -- and decomposes e = a*i + b. If @a@ and @b@ are + -- free of @i@, AND @a == 1 or -1@ THEN the upper/lower -- bound can be improved. Otherwise Nothing. -- -- Returns: Nothing or @@ -684,7 +684,7 @@ sym_bds Nothing -> oneName sym <> cur_syms -consume :: Attributes lore => VName -> SymbolTable lore -> SymbolTable lore +consume :: ASTLore lore => VName -> SymbolTable lore -> SymbolTable lore consume consumee vtable = foldl' consume' vtable $ namesToList $ expandAliases (oneName consumee) vtable where consume' vtable' v | Just e <- lookup v vtable = insertEntry v (consume'' e) vtable' @@ -735,7 +735,7 @@ hideIf :: (Entry lore -> Bool) -> SymbolTable lore -> SymbolTable lore hideIf hide vtable = vtable { bindings = M.map maybeHide $ bindings vtable } where maybeHide entry - | hide entry = FreeVar FreeVarEntry { freeVarAttr = entryInfo entry + | hide entry = FreeVar FreeVarEntry { freeVarDec = entryInfo entry , freeVarStmDepth = bindingDepth entry , freeVarRange = valueRange entry , freeVarIndex = \_ _ -> Nothing diff --git a/src/Futhark/Analysis/Usage.hs b/src/Futhark/Analysis/Usage.hs deleted file mode 100644 --- a/src/Futhark/Analysis/Usage.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -module Futhark.Analysis.Usage ( usageInStm ) where - -import Futhark.Representation.AST -import Futhark.Representation.AST.Attributes.Aliases -import qualified Futhark.Analysis.UsageTable as UT - -usageInStm :: (Attributes lore, Aliased lore) => Stm lore -> UT.UsageTable -usageInStm (Let pat lore e) = - mconcat [usageInPat, - usageInExpLore, - usageInExp e, - UT.usages (freeIn e)] - where usageInPat = - UT.usages (mconcat (map freeIn $ patternElements pat) - `namesSubtract` - namesFromList (patternNames pat)) - usageInExpLore = - UT.usages $ freeIn lore - -usageInExp :: Aliased lore => Exp lore -> UT.UsageTable -usageInExp (Apply _ args _ _) = - mconcat [ mconcat $ map UT.consumedUsage $ - namesToList $ subExpAliases arg - | (arg,d) <- args, d == Consume ] -usageInExp (DoLoop _ merge _ _) = - mconcat [ mconcat $ map UT.consumedUsage $ - namesToList $ subExpAliases se - | (v,se) <- merge, unique $ paramDeclType v ] -usageInExp (If _ tbranch fbranch _) = - foldMap UT.consumedUsage $ namesToList $ - consumedInBody tbranch <> consumedInBody fbranch -usageInExp (BasicOp (Update src _ _)) = - UT.consumedUsage src -usageInExp (Op op) = - mconcat $ map UT.consumedUsage (namesToList $ consumedInOp op) -usageInExp _ = UT.empty diff --git a/src/Futhark/Analysis/UsageTable.hs b/src/Futhark/Analysis/UsageTable.hs --- a/src/Futhark/Analysis/UsageTable.hs +++ b/src/Futhark/Analysis/UsageTable.hs @@ -3,7 +3,6 @@ -- (and if) a variable is used. module Futhark.Analysis.UsageTable ( UsageTable - , empty , without , lookup , used @@ -16,10 +15,10 @@ , consumedUsage , inResultUsage , Usages + , usageInStm ) where -import Control.Arrow (first) import Data.Bits import qualified Data.Foldable as Foldable import Data.List (foldl') @@ -27,9 +26,10 @@ import Prelude hiding (lookup) -import Futhark.Transform.Substitute -import Futhark.Representation.AST +import Futhark.IR +import Futhark.IR.Prop.Aliases +-- | A usage table. newtype UsageTable = UsageTable (M.Map VName Usages) deriving (Eq, Show) @@ -38,28 +38,20 @@ UsageTable $ M.unionWith (<>) table1 table2 instance Monoid UsageTable where - mempty = empty - -instance Substitute UsageTable where - substituteNames subst (UsageTable table) - | not $ M.null $ subst `M.intersection` table = - UsageTable $ M.fromList $ - map (first $ substituteNames subst) $ M.toList table - | otherwise = UsageTable table - -empty :: UsageTable -empty = UsageTable M.empty - + mempty = UsageTable mempty +-- | Remove these entries from the usage table. without :: UsageTable -> [VName] -> UsageTable without (UsageTable table) = UsageTable . Foldable.foldl (flip M.delete) table +-- | Look up a variable in the usage table. lookup :: VName -> UsageTable -> Maybe Usages lookup name (UsageTable table) = M.lookup name table lookupPred :: (Usages -> Bool) -> VName -> UsageTable -> Bool lookupPred f name = maybe False f . lookup name +-- | Is the variable present in the usage table? That is, has it been used? used :: VName -> UsageTable -> Bool used = lookupPred $ const True @@ -73,9 +65,11 @@ is :: Usages -> VName -> UsageTable -> Bool is = lookupPred . matches +-- | Has the variable been consumed? isConsumed :: VName -> UsageTable -> Bool isConsumed = is consumedU +-- | Has the variable been used in the 'Result' of a body? isInResult :: VName -> UsageTable -> Bool isInResult = is inResultU @@ -84,19 +78,27 @@ isUsedDirectly :: VName -> UsageTable -> Bool isUsedDirectly = is presentU +-- | Construct a usage table reflecting that these variables have been +-- used. usages :: Names -> UsageTable usages names = UsageTable $ M.fromList [ (name, presentU) | name <- namesToList names ] +-- | Construct a usage table where the given variable has been used in +-- this specific way. usage :: VName -> Usages -> UsageTable usage name uses = UsageTable $ M.singleton name uses +-- | Construct a usage table where the given variable has been consumed. consumedUsage :: VName -> UsageTable consumedUsage name = UsageTable $ M.singleton name consumedU +-- | Construct a usage table where the given variable has been used in +-- the 'Result' of a body. inResultUsage :: VName -> UsageTable inResultUsage name = UsageTable $ M.singleton name inResultU -newtype Usages = Usages Int +-- | A description of how a single variable has been used. +newtype Usages = Usages Int -- Bitmap representation for speed. deriving (Eq, Ord, Show) instance Semigroup Usages where @@ -118,3 +120,36 @@ -- | x - y, but for Usages. withoutU :: Usages -> Usages -> Usages withoutU (Usages x) (Usages y) = Usages $ x .&. complement y + +-- | Produce a usage table reflecting the use of the free variables in +-- a single statement. +usageInStm :: (ASTLore lore, Aliased lore) => Stm lore -> UsageTable +usageInStm (Let pat lore e) = + mconcat [usageInPat, + usageInExpLore, + usageInExp e, + usages (freeIn e)] + where usageInPat = + usages (mconcat (map freeIn $ patternElements pat) + `namesSubtract` + namesFromList (patternNames pat)) + usageInExpLore = + usages $ freeIn lore + +usageInExp :: Aliased lore => Exp lore -> UsageTable +usageInExp (Apply _ args _ _) = + mconcat [ mconcat $ map consumedUsage $ + namesToList $ subExpAliases arg + | (arg,d) <- args, d == Consume ] +usageInExp (DoLoop _ merge _ _) = + mconcat [ mconcat $ map consumedUsage $ + namesToList $ subExpAliases se + | (v,se) <- merge, unique $ paramDeclType v ] +usageInExp (If _ tbranch fbranch _) = + foldMap consumedUsage $ namesToList $ + consumedInBody tbranch <> consumedInBody fbranch +usageInExp (BasicOp (Update src _ _)) = + consumedUsage src +usageInExp (Op op) = + mconcat $ map consumedUsage (namesToList $ consumedInOp op) +usageInExp _ = mempty diff --git a/src/Futhark/Bench.hs b/src/Futhark/Bench.hs --- a/src/Futhark/Bench.hs +++ b/src/Futhark/Bench.hs @@ -37,14 +37,20 @@ import Futhark.Test +-- | The runtime of a single succesful run. newtype RunResult = RunResult { runMicroseconds :: Int } deriving (Eq, Show) + +-- | The results for a single named dataset is either an error +-- message, or runtime measurements along the stderr that was +-- produced. data DataResult = DataResult String (Either T.Text ([RunResult], T.Text)) deriving (Eq, Show) + +-- | The results for all datasets for some benchmark program. data BenchResult = BenchResult FilePath [DataResult] deriving (Eq, Show) --- Intermediate types to help write the JSON instances. newtype DataResults = DataResults { unDataResults :: [DataResult] } newtype BenchResults = BenchResults { unBenchResults :: [BenchResult] } diff --git a/src/Futhark/Binder.hs b/src/Futhark/Binder.hs --- a/src/Futhark/Binder.hs +++ b/src/Futhark/Binder.hs @@ -1,5 +1,7 @@ {-# LANGUAGE FlexibleContexts, GeneralizedNewtypeDeriving, TypeFamilies, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-} {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE Trustworthy #-} -- | This module defines a convenience monad/typeclass for creating -- normalised programs. module Futhark.Binder @@ -8,9 +10,6 @@ , runBinderT, runBinderT_ , runBinderT', runBinderT'_ , BinderOps (..) - , bindableMkExpAttrB - , bindableMkBodyB - , bindableMkLetNamesB , Binder , runBinder , runBinder_ @@ -19,7 +18,6 @@ -- * Non-class interface , addBinderStms , collectBinderStms - , certifyingBinder -- * The 'MonadBinder' typeclass , module Futhark.Binder.Class ) @@ -33,27 +31,28 @@ import qualified Data.Map.Strict as M import Futhark.Binder.Class -import Futhark.Representation.AST +import Futhark.IR -class Attributes lore => BinderOps lore where - mkExpAttrB :: (MonadBinder m, Lore m ~ lore) => - Pattern lore -> Exp lore -> m (ExpAttr lore) +class ASTLore lore => BinderOps lore where + mkExpDecB :: (MonadBinder m, Lore m ~ lore) => + Pattern lore -> Exp lore -> m (ExpDec lore) + mkBodyB :: (MonadBinder m, Lore m ~ lore) => Stms lore -> Result -> m (Body lore) mkLetNamesB :: (MonadBinder m, Lore m ~ lore) => [VName] -> Exp lore -> m (Stm lore) -bindableMkExpAttrB :: (MonadBinder m, Bindable (Lore m)) => - Pattern (Lore m) -> Exp (Lore m) -> m (ExpAttr (Lore m)) -bindableMkExpAttrB pat e = return $ mkExpAttr pat e + default mkExpDecB :: (MonadBinder m, Bindable lore) => + Pattern lore -> Exp lore -> m (ExpDec lore) + mkExpDecB pat e = return $ mkExpDec pat e -bindableMkBodyB :: (MonadBinder m, Bindable (Lore m)) => - Stms (Lore m) -> Result -> m (Body (Lore m)) -bindableMkBodyB stms res = return $ mkBody stms res + default mkBodyB :: (MonadBinder m, Bindable lore) => + Stms lore -> Result -> m (Body lore) + mkBodyB stms res = return $ mkBody stms res -bindableMkLetNamesB :: (MonadBinder m, Bindable (Lore m)) => - [VName] -> Exp (Lore m) -> m (Stm (Lore m)) -bindableMkLetNamesB = mkLetNames + default mkLetNamesB :: (MonadBinder m, Lore m ~ lore, Bindable lore) => + [VName] -> Exp lore -> m (Stm lore) + mkLetNamesB = mkLetNames newtype BinderT lore m a = BinderT (StateT (Stms lore, Scope lore) m a) deriving (Functor, Monad, Applicative) @@ -67,7 +66,7 @@ getNameSource = lift getNameSource putNameSource = lift . putNameSource -instance (Attributes lore, Monad m) => +instance (ASTLore lore, Monad m) => HasScope lore (BinderT lore m) where lookupType name = do t <- BinderT $ gets $ M.lookup name . snd @@ -76,7 +75,7 @@ Just t' -> return $ typeOf t' askScope = BinderT $ gets snd -instance (Attributes lore, Monad m) => +instance (ASTLore lore, Monad m) => LocalScope lore (BinderT lore m) where localScope types (BinderT m) = BinderT $ do modify $ second (M.union types) @@ -84,18 +83,16 @@ modify $ second (`M.difference` types) return x -instance (Attributes lore, MonadFreshNames m, BinderOps lore) => +instance (ASTLore lore, MonadFreshNames m, BinderOps lore) => MonadBinder (BinderT lore m) where type Lore (BinderT lore m) = lore - mkExpAttrM = mkExpAttrB + mkExpDecM = mkExpDecB mkBodyM = mkBodyB mkLetNamesM = mkLetNamesB addStms = addBinderStms collectStms = collectBinderStms - certifying = certifyingBinder - runBinderT :: MonadFreshNames m => BinderT lore m a -> Scope lore @@ -163,14 +160,6 @@ (new_stms, _) <- BinderT get BinderT $ put (old_stms, old_scope) return (x, new_stms) - -certifyingBinder :: (MonadFreshNames m, BinderOps lore) => - Certificates -> BinderT lore m a - -> BinderT lore m a -certifyingBinder cs m = do - (x, stms) <- collectStms m - addStms $ certify cs <$> stms - return x -- Utility instance defintions for MTL classes. These require -- UndecidableInstances, but save on typing elsewhere. diff --git a/src/Futhark/Binder/Class.hs b/src/Futhark/Binder/Class.hs --- a/src/Futhark/Binder/Class.hs +++ b/src/Futhark/Binder/Class.hs @@ -5,25 +5,22 @@ ( Bindable (..) , mkLet , MonadBinder (..) - , mkLetM - , bodyStms , insertStms , insertStm , letBind - , letBind_ , letBindNames - , letBindNames_ , collectStms_ , bodyBind + , attributing + , auxing , module Futhark.MonadFreshNames ) where -import Control.Monad.Writer import qualified Data.Kind -import Futhark.Representation.AST +import Futhark.IR import Futhark.MonadFreshNames -- | The class of lores that can be constructed solely from an @@ -32,15 +29,15 @@ -- often than you think, and the results thrown away. If used -- exclusively within a 'MonadBinder' instance, it is acceptable for -- them to create new bindings, however. -class (Attributes lore, - FParamAttr lore ~ DeclType, - LParamAttr lore ~ Type, +class (ASTLore lore, + FParamInfo lore ~ DeclType, + LParamInfo lore ~ Type, RetType lore ~ DeclExtType, BranchType lore ~ ExtType, - SetType (LetAttr lore)) => + SetType (LetDec lore)) => Bindable lore where mkExpPat :: [Ident] -> [Ident] -> Exp lore -> Pattern lore - mkExpAttr :: Pattern lore -> Exp lore -> ExpAttr lore + mkExpDec :: Pattern lore -> Exp lore -> ExpDec lore mkBody :: Stms lore -> Result -> Body lore mkLetNames :: (MonadFreshNames m, HasScope lore m) => [VName] -> Exp lore -> m (Stm lore) @@ -48,69 +45,97 @@ -- | A monad that supports the creation of bindings from expressions -- and bodies from bindings, with a specific lore. This is the main -- typeclass that a monad must implement in order for it to be useful --- for generating or modifying Futhark code. +-- for generating or modifying Futhark code. Most importantly +-- maintains a current state of 'Stms' (as well as a 'Scope') that +-- have been added with 'addStm'. -- -- Very important: the methods should not have any significant side -- effects! They may be called more often than you think, and the -- results thrown away. It is acceptable for them to create new -- bindings, however. -class (Attributes (Lore m), +class (ASTLore (Lore m), MonadFreshNames m, Applicative m, Monad m, LocalScope (Lore m) m) => MonadBinder m where type Lore m :: Data.Kind.Type - mkExpAttrM :: Pattern (Lore m) -> Exp (Lore m) -> m (ExpAttr (Lore m)) + mkExpDecM :: Pattern (Lore m) -> Exp (Lore m) -> m (ExpDec (Lore m)) mkBodyM :: Stms (Lore m) -> Result -> m (Body (Lore m)) mkLetNamesM :: [VName] -> Exp (Lore m) -> m (Stm (Lore m)) + + -- | Add a statement to the 'Stms' under construction. addStm :: Stm (Lore m) -> m () addStm = addStms . oneStm + + -- | Add multiple statements to the 'Stms' under construction. addStms :: Stms (Lore m) -> m () + + -- | Obtain the statements constructed during a monadic action, + -- instead of adding them to the state. collectStms :: m a -> m (a, Stms (Lore m)) + + -- | Add the provided certificates to any statements added during + -- execution of the action. certifying :: Certificates -> m a -> m a + certifying = censorStms . fmap . certify -mkLetM :: MonadBinder m => Pattern (Lore m) -> Exp (Lore m) -> m (Stm (Lore m)) -mkLetM pat e = Let pat <$> (StmAux mempty <$> mkExpAttrM pat e) <*> pure e +-- | Apply a function to the statements added by this action. +censorStms :: MonadBinder m => + (Stms (Lore m) -> Stms (Lore m)) + -> m a -> m a +censorStms f m = do + (x, stms) <- collectStms m + addStms $ f stms + return x -letBind :: MonadBinder m => - Pattern (Lore m) -> Exp (Lore m) -> m [Ident] -letBind pat e = do - bnd <- mkLetM pat e - addStm bnd - return $ patternValueIdents $ stmPattern bnd +-- | Add the given attributes to any statements added by this action. +attributing :: MonadBinder m => Attrs -> m a -> m a +attributing attrs = censorStms $ fmap onStm + where onStm (Let pat aux e) = + Let pat aux { stmAuxAttrs = attrs <> stmAuxAttrs aux } e -letBind_ :: MonadBinder m => +-- | Add the certificates and attributes to any statements added by +-- this action. +auxing :: MonadBinder m => StmAux anylore -> m a -> m a +auxing (StmAux cs attrs _) = censorStms $ fmap onStm + where onStm (Let pat aux e) = + Let pat aux' e + where aux' = aux { stmAuxAttrs = attrs <> stmAuxAttrs aux + , stmAuxCerts = cs <> stmAuxCerts aux + } + +-- | Add a statement with the given pattern and expression. +letBind :: MonadBinder m => Pattern (Lore m) -> Exp (Lore m) -> m () -letBind_ pat e = void $ letBind pat e +letBind pat e = + addStm =<< Let pat <$> (defAux <$> mkExpDecM pat e) <*> pure e +-- | Construct a 'Stm' from identifiers for the context- and value +-- part of the pattern, as well as the expression. mkLet :: Bindable lore => [Ident] -> [Ident] -> Exp lore -> Stm lore mkLet ctx val e = let pat = mkExpPat ctx val e - attr = mkExpAttr pat e - in Let pat (StmAux mempty attr) e - -letBindNames :: MonadBinder m => - [VName] -> Exp (Lore m) -> m [Ident] -letBindNames names e = do - bnd <- mkLetNamesM names e - addStm bnd - return $ patternValueIdents $ stmPattern bnd + dec = mkExpDec pat e + in Let pat (defAux dec) e -letBindNames_ :: MonadBinder m => - [VName] -> Exp (Lore m) -> m () -letBindNames_ names e = void $ letBindNames names e +-- | Add a statement with the given pattern element names and +-- expression. +letBindNames :: MonadBinder m => [VName] -> Exp (Lore m) -> m () +letBindNames names e = addStm =<< mkLetNamesM names e +-- | As 'collectStms', but throw away the ordinary result. collectStms_ :: MonadBinder m => m a -> m (Stms (Lore m)) collectStms_ = fmap snd . collectStms +-- | Add the statements of the body, then return the body result. bodyBind :: MonadBinder m => Body (Lore m) -> m [SubExp] -bodyBind (Body _ bnds es) = do - addStms bnds +bodyBind (Body _ stms es) = do + addStms stms return es --- | Add several bindings at the outermost level of a 'Body'. +-- | Add several bindings at the outermost level of a t'Body'. insertStms :: Bindable lore => Stms lore -> Body lore -> Body lore -insertStms bnds1 (Body _ bnds2 res) = mkBody (bnds1<>bnds2) res +insertStms stms1 (Body _ stms2 res) = mkBody (stms1<>stms2) res --- | Add a single binding at the outermost level of a 'Body'. +-- | Add a single binding at the outermost level of a t'Body'. insertStm :: Bindable lore => Stm lore -> Body lore -> Body lore insertStm = insertStms . oneStm diff --git a/src/Futhark/CLI/Dataset.hs b/src/Futhark/CLI/Dataset.hs --- a/src/Futhark/CLI/Dataset.hs +++ b/src/Futhark/CLI/Dataset.hs @@ -1,6 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Strict #-} -{-# LANGUAGE StrictData #-} -- | @futhark dataset@ module Futhark.CLI.Dataset (main) where @@ -21,7 +20,7 @@ import Language.Futhark.Syntax hiding (Value, ValueType, PrimValue(..), IntValue(..), FloatValue(..)) -import Language.Futhark.Attributes (UncheckedTypeExp, namesToPrimTypes) +import Language.Futhark.Prop (UncheckedTypeExp, namesToPrimTypes) import Language.Futhark.Parser import Language.Futhark.Pretty () diff --git a/src/Futhark/CLI/Dev.hs b/src/Futhark/CLI/Dev.hs --- a/src/Futhark/CLI/Dev.hs +++ b/src/Futhark/CLI/Dev.hs @@ -20,12 +20,12 @@ import Language.Futhark.Parser (parseFuthark) import Futhark.Util.Options import Futhark.Pipeline -import qualified Futhark.Representation.SOACS as SOACS -import qualified Futhark.Representation.Kernels as Kernels -import qualified Futhark.Representation.Seq as Seq -import qualified Futhark.Representation.KernelsMem as KernelsMem -import qualified Futhark.Representation.SeqMem as SeqMem -import Futhark.Representation.AST (Prog, pretty) +import qualified Futhark.IR.SOACS as SOACS +import qualified Futhark.IR.Kernels as Kernels +import qualified Futhark.IR.Seq as Seq +import qualified Futhark.IR.KernelsMem as KernelsMem +import qualified Futhark.IR.SeqMem as SeqMem +import Futhark.IR (Prog, pretty) import Futhark.TypeCheck (Checkable) import qualified Futhark.Util.Pretty as PP @@ -192,7 +192,7 @@ passOption (passDescription pass) (UntypedPass perform) short long where perform s config = do prog <- getProg (passName pass) s - putProg <$> runPasses (onePass pass) config prog + putProg <$> runPipeline (onePass pass) config prog long = [passLongOption pass] @@ -214,15 +214,15 @@ simplifyOption short = passOption (passDescription pass) (UntypedPass perform) short long where perform (SOACS prog) config = - SOACS <$> runPasses (onePass simplifySOACS) config prog + SOACS <$> runPipeline (onePass simplifySOACS) config prog perform (Kernels prog) config = - Kernels <$> runPasses (onePass simplifyKernels) config prog + Kernels <$> runPipeline (onePass simplifyKernels) config prog perform (Seq prog) config = - Seq <$> runPasses (onePass simplifySeq) config prog + Seq <$> runPipeline (onePass simplifySeq) config prog perform (SeqMem prog) config = - SeqMem <$> runPasses (onePass simplifySeqMem) config prog + SeqMem <$> runPipeline (onePass simplifySeqMem) config prog perform (KernelsMem prog) config = - KernelsMem <$> runPasses (onePass simplifyKernelsMem) config prog + KernelsMem <$> runPipeline (onePass simplifyKernelsMem) config prog long = [passLongOption pass] pass = simplifySOACS @@ -232,10 +232,10 @@ passOption (passDescription pass) (UntypedPass perform) short long where perform (Kernels prog) config = KernelsMem <$> - runPasses (onePass Kernels.explicitAllocations) config prog + runPipeline (onePass Kernels.explicitAllocations) config prog perform (Seq prog) config = SeqMem <$> - runPasses (onePass Seq.explicitAllocations) config prog + runPipeline (onePass Seq.explicitAllocations) config prog perform s _ = externalErrorS $ "Pass '" ++ passDescription pass ++ "' cannot operate on " ++ representation s @@ -248,10 +248,10 @@ passOption (passDescription pass) (UntypedPass perform) short long where perform (Kernels prog) config = Kernels <$> - runPasses (onePass inPlaceLoweringKernels) config prog + runPipeline (onePass inPlaceLoweringKernels) config prog perform (Seq prog) config = Seq <$> - runPasses (onePass inPlaceLoweringSeq) config prog + runPipeline (onePass inPlaceLoweringSeq) config prog perform s _ = externalErrorS $ "Pass '" ++ passDescription pass ++ "' cannot operate on " ++ representation s @@ -263,15 +263,15 @@ cseOption short = passOption (passDescription pass) (UntypedPass perform) short long where perform (SOACS prog) config = - SOACS <$> runPasses (onePass $ performCSE True) config prog + SOACS <$> runPipeline (onePass $ performCSE True) config prog perform (Kernels prog) config = - Kernels <$> runPasses (onePass $ performCSE True) config prog + Kernels <$> runPipeline (onePass $ performCSE True) config prog perform (Seq prog) config = - Seq <$> runPasses (onePass $ performCSE True) config prog + Seq <$> runPipeline (onePass $ performCSE True) config prog perform (SeqMem prog) config = - SeqMem <$> runPasses (onePass $ performCSE False) config prog + SeqMem <$> runPipeline (onePass $ performCSE False) config prog perform (KernelsMem prog) config = - KernelsMem <$> runPasses (onePass $ performCSE False) config prog + KernelsMem <$> runPipeline (onePass $ performCSE False) config prog long = [passLongOption pass] pass = performCSE True :: Pass SOACS.SOACS SOACS.SOACS @@ -289,7 +289,7 @@ where pipelinePass rep config = case getprog rep of Just prog -> - repf <$> runPasses pipeline config prog + repf <$> runPipeline pipeline config prog Nothing -> externalErrorS $ "Expected " ++ repdesc ++ " representation, but got " ++ representation rep diff --git a/src/Futhark/CLI/Query.hs b/src/Futhark/CLI/Query.hs --- a/src/Futhark/CLI/Query.hs +++ b/src/Futhark/CLI/Query.hs @@ -3,9 +3,9 @@ import Text.Read (readMaybe) -import Data.Loc import Futhark.Compiler import Futhark.Util.Options +import Futhark.Util.Loc import Language.Futhark.Query import Language.Futhark.Syntax diff --git a/src/Futhark/CLI/REPL.hs b/src/Futhark/CLI/REPL.hs --- a/src/Futhark/CLI/REPL.hs +++ b/src/Futhark/CLI/REPL.hs @@ -10,7 +10,6 @@ import Control.Exception import Data.Char import Data.List (intercalate, intersperse) -import Data.Loc import Data.Maybe import Data.Version import Control.Monad @@ -191,7 +190,7 @@ return $ "[" ++ show i ++ "]> " mkOpen :: FilePath -> UncheckedDec -mkOpen f = OpenDec (ModImport f NoInfo noLoc) noLoc +mkOpen f = OpenDec (ModImport f NoInfo mempty) mempty -- The ExceptT part is more of a continuation, really. newtype FutharkiM a = @@ -243,7 +242,7 @@ onDec :: UncheckedDec -> FutharkiM () onDec d = do (imports, src, tenv, ienv) <- getIt - cur_import <- T.mkInitialImport . fromMaybe "." <$> gets futharkiLoaded + cur_import <- gets $ T.mkInitialImport . fromMaybe "." . futharkiLoaded -- Most of the complexity here concerns the dealing with the fact -- that 'import "foo"' is a declaration. We have to involve a lot @@ -381,7 +380,7 @@ unbreakCommand :: Command unbreakCommand _ = do - top <- fmap (NE.head . breakingStack) <$> gets futharkiBreaking + top <- gets $ fmap (NE.head . breakingStack) . futharkiBreaking case top of Nothing -> liftIO $ putStrLn "Not currently stopped at a breakpoint." Just top' -> do modify $ \s -> s { futharkiSkipBreaks = locOf top' : futharkiSkipBreaks s } @@ -389,7 +388,7 @@ frameCommand :: Command frameCommand which = do - maybe_stack <- fmap breakingStack <$> gets futharkiBreaking + maybe_stack <- gets $ fmap breakingStack . futharkiBreaking case (maybe_stack, readMaybe $ T.unpack which) of (Just stack, Just i) | frame:_ <- NE.drop i stack -> do diff --git a/src/Futhark/CLI/Run.hs b/src/Futhark/CLI/Run.hs --- a/src/Futhark/CLI/Run.hs +++ b/src/Futhark/CLI/Run.hs @@ -6,7 +6,6 @@ import Control.Monad.Free.Church import Control.Exception -import Data.Loc import Data.Maybe import qualified Data.Map as M import Control.Monad @@ -126,7 +125,7 @@ badOnLeft p (Left err) = throwError $ p err mkOpen :: FilePath -> UncheckedDec -mkOpen f = OpenDec (ModImport f NoInfo noLoc) noLoc +mkOpen f = OpenDec (ModImport f NoInfo mempty) mempty runInterpreter' :: MonadIO m => F I.ExtOp a -> m (Either I.InterpreterError a) runInterpreter' m = runF m (return . Right) intOp diff --git a/src/Futhark/CodeGen/Backends/CCUDA.hs b/src/Futhark/CodeGen/Backends/CCUDA.hs --- a/src/Futhark/CodeGen/Backends/CCUDA.hs +++ b/src/Futhark/CodeGen/Backends/CCUDA.hs @@ -1,5 +1,6 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TupleSections #-} +-- | Code generation for CUDA. module Futhark.CodeGen.Backends.CCUDA ( compileProg , GC.CParts(..) @@ -14,7 +15,7 @@ import qualified Futhark.CodeGen.Backends.GenericC as GC import qualified Futhark.CodeGen.ImpGen.CUDA as ImpGen -import Futhark.Representation.KernelsMem +import Futhark.IR.KernelsMem hiding (GetSize, CmpSizeLe, GetSizeMax) import Futhark.MonadFreshNames import Futhark.CodeGen.ImpCode.OpenCL diff --git a/src/Futhark/CodeGen/Backends/CCUDA/Boilerplate.hs b/src/Futhark/CodeGen/Backends/CCUDA/Boilerplate.hs --- a/src/Futhark/CodeGen/Backends/CCUDA/Boilerplate.hs +++ b/src/Futhark/CodeGen/Backends/CCUDA/Boilerplate.hs @@ -1,5 +1,6 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} +-- | Various boilerplate definitions for the CUDA backend. module Futhark.CodeGen.Backends.CCUDA.Boilerplate ( generateBoilerplate @@ -18,6 +19,8 @@ errorMsgNumArgs :: ErrorMsg a -> Int errorMsgNumArgs = length . errorMsgArgTypes +-- | Called after most code has been generated to generate the bulk of +-- the boilerplate. generateBoilerplate :: String -> String -> M.Map KernelName Safety -> M.Map Name SizeClass -> [FailureMsg] diff --git a/src/Futhark/CodeGen/Backends/COpenCL.hs b/src/Futhark/CodeGen/Backends/COpenCL.hs --- a/src/Futhark/CodeGen/Backends/COpenCL.hs +++ b/src/Futhark/CodeGen/Backends/COpenCL.hs @@ -1,4 +1,5 @@ {-# LANGUAGE QuasiQuotes, FlexibleContexts #-} +-- | Code generation for C with OpenCL. module Futhark.CodeGen.Backends.COpenCL ( compileProg , GC.CParts(..) @@ -13,7 +14,7 @@ import qualified Language.C.Syntax as C import qualified Language.C.Quote.OpenCL as C -import Futhark.Representation.KernelsMem +import Futhark.IR.KernelsMem hiding (GetSize, CmpSizeLe, GetSizeMax) import Futhark.CodeGen.Backends.COpenCL.Boilerplate import qualified Futhark.CodeGen.Backends.GenericC as GC @@ -22,6 +23,7 @@ import qualified Futhark.CodeGen.ImpGen.OpenCL as ImpGen import Futhark.MonadFreshNames +-- | Compile the program to C with calls to OpenCL. compileProg :: MonadFreshNames m => Prog KernelsMem -> m GC.CParts compileProg prog = do (Program opencl_code opencl_prelude kernels diff --git a/src/Futhark/CodeGen/Backends/COpenCL/Boilerplate.hs b/src/Futhark/CodeGen/Backends/COpenCL/Boilerplate.hs --- a/src/Futhark/CodeGen/Backends/COpenCL/Boilerplate.hs +++ b/src/Futhark/CodeGen/Backends/COpenCL/Boilerplate.hs @@ -56,6 +56,8 @@ &ctx->$id:(kernelRuns name), &ctx->$id:(kernelRuntime name))|] +-- | Called after most code has been generated to generate the bulk of +-- the boilerplate. generateBoilerplate :: String -> String -> [String] -> M.Map KernelName Safety -> [PrimType] -> M.Map Name SizeClass -> [FailureMsg] diff --git a/src/Futhark/CodeGen/Backends/CSOpenCL.hs b/src/Futhark/CodeGen/Backends/CSOpenCL.hs --- a/src/Futhark/CodeGen/Backends/CSOpenCL.hs +++ b/src/Futhark/CodeGen/Backends/CSOpenCL.hs @@ -6,7 +6,7 @@ import Control.Monad import Data.List (intersperse) -import Futhark.Representation.KernelsMem (Prog, KernelsMem, int32) +import Futhark.IR.KernelsMem (Prog, KernelsMem, int32) import Futhark.CodeGen.Backends.CSOpenCL.Boilerplate import qualified Futhark.CodeGen.Backends.GenericCSharp as CS import qualified Futhark.CodeGen.ImpCode.OpenCL as Imp diff --git a/src/Futhark/CodeGen/Backends/GenericC.hs b/src/Futhark/CodeGen/Backends/GenericC.hs --- a/src/Futhark/CodeGen/Backends/GenericC.hs +++ b/src/Futhark/CodeGen/Backends/GenericC.hs @@ -1,6 +1,7 @@ {-# LANGUAGE QuasiQuotes, GeneralizedNewtypeDeriving, FlexibleInstances #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE Trustworthy #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | C code generator framework. module Futhark.CodeGen.Backends.GenericC @@ -85,10 +86,10 @@ import Futhark.CodeGen.ImpCode import Futhark.MonadFreshNames -import Futhark.CodeGen.Backends.SimpleRepresentation +import Futhark.CodeGen.Backends.SimpleRep import Futhark.CodeGen.Backends.GenericC.Options import Futhark.Util (zEncodeString) -import Futhark.Representation.AST.Attributes (isBuiltInFunction) +import Futhark.IR.Prop (isBuiltInFunction) data CompilerState s = CompilerState { @@ -494,7 +495,7 @@ rawMem :: VName -> CompilerM op s C.Exp rawMem v = rawMem' <$> fat <*> pure v - where fat = (&&) <$> asks envFatMemory <*> (isNothing <$> cacheMem v) + where fat = asks ((&&) . envFatMemory) <*> (isNothing <$> cacheMem v) rawMem' :: C.ToExp a => Bool -> a -> C.Exp rawMem' True e = [C.cexp|$exp:e.mem|] diff --git a/src/Futhark/CodeGen/Backends/GenericCSharp.hs b/src/Futhark/CodeGen/Backends/GenericCSharp.hs --- a/src/Futhark/CodeGen/Backends/GenericCSharp.hs +++ b/src/Futhark/CodeGen/Backends/GenericCSharp.hs @@ -73,9 +73,9 @@ import Data.Maybe import qualified Data.Map as M -import Futhark.Representation.Primitive hiding (Bool) +import Futhark.IR.Primitive hiding (Bool) import Futhark.MonadFreshNames -import Futhark.Representation.AST.Syntax (Space(..)) +import Futhark.IR.Syntax (Space(..)) import qualified Futhark.CodeGen.ImpCode as Imp import Futhark.CodeGen.Backends.GenericCSharp.AST import Futhark.CodeGen.Backends.GenericCSharp.Options @@ -302,7 +302,7 @@ getVarAssigned :: VName -> CompilerM op s Bool getVarAssigned vname = - elem vname <$> gets compAssignedVars + gets $ elem vname . compAssignedVars setVarAssigned :: VName -> CompilerM op s () setVarAssigned vname = modify $ \s -> diff --git a/src/Futhark/CodeGen/Backends/GenericPython.hs b/src/Futhark/CodeGen/Backends/GenericPython.hs --- a/src/Futhark/CodeGen/Backends/GenericPython.hs +++ b/src/Futhark/CodeGen/Backends/GenericPython.hs @@ -53,15 +53,15 @@ import Data.Maybe import qualified Data.Map as M -import Futhark.Representation.Primitive hiding (Bool) +import Futhark.IR.Primitive hiding (Bool) import Futhark.MonadFreshNames -import Futhark.Representation.AST.Syntax (Space(..)) +import Futhark.IR.Syntax (Space(..)) import qualified Futhark.CodeGen.ImpCode as Imp import Futhark.CodeGen.Backends.GenericPython.AST import Futhark.CodeGen.Backends.GenericPython.Options import Futhark.CodeGen.Backends.GenericPython.Definitions import Futhark.Util (zEncodeString) -import Futhark.Representation.AST.Attributes (isBuiltInFunction) +import Futhark.IR.Prop (isBuiltInFunction) -- | A substitute expression compiler, tried before the main -- compilation function. diff --git a/src/Futhark/CodeGen/Backends/PyOpenCL.hs b/src/Futhark/CodeGen/Backends/PyOpenCL.hs --- a/src/Futhark/CodeGen/Backends/PyOpenCL.hs +++ b/src/Futhark/CodeGen/Backends/PyOpenCL.hs @@ -6,7 +6,7 @@ import Control.Monad import qualified Data.Map as M -import Futhark.Representation.KernelsMem (Prog, KernelsMem) +import Futhark.IR.KernelsMem (Prog, KernelsMem) import Futhark.CodeGen.Backends.PyOpenCL.Boilerplate import qualified Futhark.CodeGen.Backends.GenericPython as Py import qualified Futhark.CodeGen.ImpCode.OpenCL as Imp diff --git a/src/Futhark/CodeGen/Backends/PyOpenCL/Boilerplate.hs b/src/Futhark/CodeGen/Backends/PyOpenCL/Boilerplate.hs --- a/src/Futhark/CodeGen/Backends/PyOpenCL/Boilerplate.hs +++ b/src/Futhark/CodeGen/Backends/PyOpenCL/Boilerplate.hs @@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} +-- | Various boilerplate definitions for the PyOpenCL backend. module Futhark.CodeGen.Backends.PyOpenCL.Boilerplate ( openClInit , openClPrelude diff --git a/src/Futhark/CodeGen/Backends/SequentialC.hs b/src/Futhark/CodeGen/Backends/SequentialC.hs --- a/src/Futhark/CodeGen/Backends/SequentialC.hs +++ b/src/Futhark/CodeGen/Backends/SequentialC.hs @@ -13,7 +13,7 @@ import qualified Language.C.Quote.OpenCL as C -import Futhark.Representation.SeqMem +import Futhark.IR.SeqMem import qualified Futhark.CodeGen.ImpCode.Sequential as Imp import qualified Futhark.CodeGen.ImpGen.Sequential as ImpGen import qualified Futhark.CodeGen.Backends.GenericC as GC diff --git a/src/Futhark/CodeGen/Backends/SequentialCSharp.hs b/src/Futhark/CodeGen/Backends/SequentialCSharp.hs --- a/src/Futhark/CodeGen/Backends/SequentialCSharp.hs +++ b/src/Futhark/CodeGen/Backends/SequentialCSharp.hs @@ -4,7 +4,7 @@ import Control.Monad -import Futhark.Representation.SeqMem +import Futhark.IR.SeqMem import qualified Futhark.CodeGen.ImpCode.Sequential as Imp import qualified Futhark.CodeGen.ImpGen.Sequential as ImpGen import qualified Futhark.CodeGen.Backends.GenericCSharp as CS diff --git a/src/Futhark/CodeGen/Backends/SequentialPython.hs b/src/Futhark/CodeGen/Backends/SequentialPython.hs --- a/src/Futhark/CodeGen/Backends/SequentialPython.hs +++ b/src/Futhark/CodeGen/Backends/SequentialPython.hs @@ -4,7 +4,7 @@ import Control.Monad -import Futhark.Representation.SeqMem +import Futhark.IR.SeqMem import qualified Futhark.CodeGen.ImpCode.Sequential as Imp import qualified Futhark.CodeGen.ImpGen.Sequential as ImpGen import qualified Futhark.CodeGen.Backends.GenericPython as GenericPython diff --git a/src/Futhark/CodeGen/Backends/SimpleRep.hs b/src/Futhark/CodeGen/Backends/SimpleRep.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/CodeGen/Backends/SimpleRep.hs @@ -0,0 +1,759 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE Trustworthy #-} +-- | Simple C runtime representation. +module Futhark.CodeGen.Backends.SimpleRep + ( tupleField + , funName + , defaultMemBlockType + , primTypeToCType + , signedPrimTypeToCType + + -- * Primitive value operations + , cIntOps + , cFloat32Ops, cFloat32Funs + , cFloat64Ops, cFloat64Funs + , cFloatConvOps + ) + where + +import qualified Language.C.Syntax as C +import qualified Language.C.Quote.C as C + +import Futhark.CodeGen.ImpCode +import Futhark.Util.Pretty (prettyOneLine) +import Futhark.Util (zEncodeString) + +-- | The C type corresponding to a signed integer type. +intTypeToCType :: IntType -> C.Type +intTypeToCType Int8 = [C.cty|typename int8_t|] +intTypeToCType Int16 = [C.cty|typename int16_t|] +intTypeToCType Int32 = [C.cty|typename int32_t|] +intTypeToCType Int64 = [C.cty|typename int64_t|] + +-- | The C type corresponding to an unsigned integer type. +uintTypeToCType :: IntType -> C.Type +uintTypeToCType Int8 = [C.cty|typename uint8_t|] +uintTypeToCType Int16 = [C.cty|typename uint16_t|] +uintTypeToCType Int32 = [C.cty|typename uint32_t|] +uintTypeToCType Int64 = [C.cty|typename uint64_t|] + +-- | The C type corresponding to a float type. +floatTypeToCType :: FloatType -> C.Type +floatTypeToCType Float32 = [C.cty|float|] +floatTypeToCType Float64 = [C.cty|double|] + +-- | The C type corresponding to a primitive type. Integers are +-- assumed to be unsigned. +primTypeToCType :: PrimType -> C.Type +primTypeToCType (IntType t) = intTypeToCType t +primTypeToCType (FloatType t) = floatTypeToCType t +primTypeToCType Bool = [C.cty|typename bool|] +primTypeToCType Cert = [C.cty|typename bool|] + +-- | The C type corresponding to a primitive type. Integers are +-- assumed to have the specified sign. +signedPrimTypeToCType :: Signedness -> PrimType -> C.Type +signedPrimTypeToCType TypeUnsigned (IntType t) = uintTypeToCType t +signedPrimTypeToCType TypeDirect (IntType t) = intTypeToCType t +signedPrimTypeToCType _ t = primTypeToCType t + +-- | @tupleField i@ is the name of field number @i@ in a tuple. +tupleField :: Int -> String +tupleField i = "v" ++ show i + +-- | @funName f@ is the name of the C function corresponding to +-- the Futhark function @f@. +funName :: Name -> String +funName = ("futrts_"++) . zEncodeString . nameToString + +funName' :: String -> String +funName' = funName . nameFromString + +-- | The type of memory blocks in the default memory space. +defaultMemBlockType :: C.Type +defaultMemBlockType = [C.cty|char*|] + +cIntOps :: [C.Definition] +cIntOps = concatMap (`map` [minBound..maxBound]) ops + ++ cIntPrimFuns + where ops = [mkAdd, mkSub, mkMul, + mkUDiv, mkUMod, + mkSDiv, mkSMod, + mkSQuot, mkSRem, + mkSMin, mkUMin, + mkSMax, mkUMax, + mkShl, mkLShr, mkAShr, + mkAnd, mkOr, mkXor, + mkUlt, mkUle, mkSlt, mkSle, + mkPow, + mkIToB, mkBToI + ] ++ + map mkSExt [minBound..maxBound] ++ + map mkZExt [minBound..maxBound] + + taggedI s Int8 = s ++ "8" + taggedI s Int16 = s ++ "16" + taggedI s Int32 = s ++ "32" + taggedI s Int64 = s ++ "64" + + -- Use unsigned types for add/sub/mul so we can do + -- well-defined overflow. + mkAdd = simpleUintOp "add" [C.cexp|x + y|] + mkSub = simpleUintOp "sub" [C.cexp|x - y|] + mkMul = simpleUintOp "mul" [C.cexp|x * y|] + mkUDiv = simpleUintOp "udiv" [C.cexp|x / y|] + mkUMod = simpleUintOp "umod" [C.cexp|x % y|] + mkUMax = simpleUintOp "umax" [C.cexp|x < y ? y : x|] + mkUMin = simpleUintOp "umin" [C.cexp|x < y ? x : y|] + + mkSDiv t = + let ct = intTypeToCType t + in [C.cedecl|static inline $ty:ct $id:(taggedI "sdiv" t)($ty:ct x, $ty:ct y) { + $ty:ct q = x / y; + $ty:ct r = x % y; + return q - + (((r != 0) && ((r < 0) != (y < 0))) ? 1 : 0); + }|] + mkSMod t = + let ct = intTypeToCType t + in [C.cedecl|static inline $ty:ct $id:(taggedI "smod" t)($ty:ct x, $ty:ct y) { + $ty:ct r = x % y; + return r + + ((r == 0 || (x > 0 && y > 0) || (x < 0 && y < 0)) ? 0 : y); + }|] + + mkSQuot = simpleIntOp "squot" [C.cexp|x / y|] + mkSRem = simpleIntOp "srem" [C.cexp|x % y|] + mkSMax = simpleIntOp "smax" [C.cexp|x < y ? y : x|] + mkSMin = simpleIntOp "smin" [C.cexp|x < y ? x : y|] + mkShl = simpleUintOp "shl" [C.cexp|x << y|] + mkLShr = simpleUintOp "lshr" [C.cexp|x >> y|] + mkAShr = simpleIntOp "ashr" [C.cexp|x >> y|] + mkAnd = simpleUintOp "and" [C.cexp|x & y|] + mkOr = simpleUintOp "or" [C.cexp|x | y|] + mkXor = simpleUintOp "xor" [C.cexp|x ^ y|] + mkUlt = uintCmpOp "ult" [C.cexp|x < y|] + mkUle = uintCmpOp "ule" [C.cexp|x <= y|] + mkSlt = intCmpOp "slt" [C.cexp|x < y|] + mkSle = intCmpOp "sle" [C.cexp|x <= y|] + + -- We define some operations as macros rather than functions, + -- because this allows us to use them as constant expressions + -- in things like array sizes and static initialisers. + macro name rhs = + [C.cedecl|$esc:("#define " ++ name ++ "(x) (" ++ prettyOneLine rhs ++ ")")|] + + mkPow t = + let ct = intTypeToCType t + in [C.cedecl|static inline $ty:ct $id:(taggedI "pow" t)($ty:ct x, $ty:ct y) { + $ty:ct res = 1, rem = y; + while (rem != 0) { + if (rem & 1) { + res *= x; + } + rem >>= 1; + x *= x; + } + return res; + }|] + + mkSExt from_t to_t = macro name [C.cexp|($ty:to_ct)(($ty:from_ct)x)|] + where name = "sext_"++pretty from_t++"_"++pretty to_t + from_ct = intTypeToCType from_t + to_ct = intTypeToCType to_t + + mkZExt from_t to_t = macro name [C.cexp|($ty:to_ct)(($ty:from_ct)x)|] + where name = "zext_"++pretty from_t++"_"++pretty to_t + from_ct = uintTypeToCType from_t + to_ct = uintTypeToCType to_t + + mkBToI to_t = + [C.cedecl|static inline $ty:to_ct + $id:name($ty:from_ct x) { return x; } |] + where name = "btoi_bool_"++pretty to_t + from_ct = primTypeToCType Bool + to_ct = intTypeToCType to_t + + mkIToB from_t = + [C.cedecl|static inline $ty:to_ct + $id:name($ty:from_ct x) { return x; } |] + where name = "itob_"++pretty from_t++"_bool" + to_ct = primTypeToCType Bool + from_ct = intTypeToCType from_t + + simpleUintOp s e t = + [C.cedecl|static inline $ty:ct $id:(taggedI s t)($ty:ct x, $ty:ct y) { return $exp:e; }|] + where ct = uintTypeToCType t + simpleIntOp s e t = + [C.cedecl|static inline $ty:ct $id:(taggedI s t)($ty:ct x, $ty:ct y) { return $exp:e; }|] + where ct = intTypeToCType t + intCmpOp s e t = + [C.cedecl|static inline typename bool $id:(taggedI s t)($ty:ct x, $ty:ct y) { return $exp:e; }|] + where ct = intTypeToCType t + uintCmpOp s e t = + [C.cedecl|static inline typename bool $id:(taggedI s t)($ty:ct x, $ty:ct y) { return $exp:e; }|] + where ct = uintTypeToCType t + +cIntPrimFuns :: [C.Definition] +cIntPrimFuns = + [C.cunit| +$esc:("#if defined(__OPENCL_VERSION__)") + static typename int32_t $id:(funName' "popc8") (typename int8_t x) { + return popcount(x); + } + static typename int32_t $id:(funName' "popc16") (typename int16_t x) { + return popcount(x); + } + static typename int32_t $id:(funName' "popc32") (typename int32_t x) { + return popcount(x); + } + static typename int32_t $id:(funName' "popc64") (typename int64_t x) { + return popcount(x); + } +$esc:("#elif defined(__CUDA_ARCH__)") + static typename int32_t $id:(funName' "popc8") (typename int8_t x) { + return __popc(zext_i8_i32(x)); + } + static typename int32_t $id:(funName' "popc16") (typename int16_t x) { + return __popc(zext_i16_i32(x)); + } + static typename int32_t $id:(funName' "popc32") (typename int32_t x) { + return __popc(x); + } + static typename int32_t $id:(funName' "popc64") (typename int64_t x) { + return __popcll(x); + } +$esc:("#else") + static typename int32_t $id:(funName' "popc8") (typename int8_t x) { + int c = 0; + for (; x; ++c) { + x &= x - 1; + } + return c; + } + static typename int32_t $id:(funName' "popc16") (typename int16_t x) { + int c = 0; + for (; x; ++c) { + x &= x - 1; + } + return c; + } + static typename int32_t $id:(funName' "popc32") (typename int32_t x) { + int c = 0; + for (; x; ++c) { + x &= x - 1; + } + return c; + } + static typename int32_t $id:(funName' "popc64") (typename int64_t x) { + int c = 0; + for (; x; ++c) { + x &= x - 1; + } + return c; + } +$esc:("#endif") + +$esc:("#if defined(__OPENCL_VERSION__)") + static typename uint8_t $id:(funName' "mul_hi8") (typename uint8_t a, typename uint8_t b) { + return mul_hi(a, b); + } + static typename uint16_t $id:(funName' "mul_hi16") (typename uint16_t a, typename uint16_t b) { + return mul_hi(a, b); + } + static typename uint32_t $id:(funName' "mul_hi32") (typename uint32_t a, typename uint32_t b) { + return mul_hi(a, b); + } + static typename uint64_t $id:(funName' "mul_hi64") (typename uint64_t a, typename uint64_t b) { + return mul_hi(a, b); + } +$esc:("#elif defined(__CUDA_ARCH__)") + static typename uint8_t $id:(funName' "mul_hi8") (typename uint8_t a, typename uint8_t b) { + typename uint16_t aa = a; + typename uint16_t bb = b; + return (aa * bb) >> 8; + } + static typename uint16_t $id:(funName' "mul_hi16") (typename uint16_t a, typename uint16_t b) { + typename uint32_t aa = a; + typename uint32_t bb = b; + return (aa * bb) >> 16; + } + static typename uint32_t $id:(funName' "mul_hi32") (typename uint32_t a, typename uint32_t b) { + return mulhi(a, b); + } + static typename uint64_t $id:(funName' "mul_hi64") (typename uint64_t a, typename uint64_t b) { + return mul64hi(a, b); + } +$esc:("#else") + static typename uint8_t $id:(funName' "mul_hi8") (typename uint8_t a, typename uint8_t b) { + typename uint16_t aa = a; + typename uint16_t bb = b; + return (aa * bb) >> 8; + } + static typename uint16_t $id:(funName' "mul_hi16") (typename uint16_t a, typename uint16_t b) { + typename uint32_t aa = a; + typename uint32_t bb = b; + return (aa * bb) >> 16; + } + static typename uint32_t $id:(funName' "mul_hi32") (typename uint32_t a, typename uint32_t b) { + typename uint64_t aa = a; + typename uint64_t bb = b; + return (aa * bb) >> 32; + } + static typename uint64_t $id:(funName' "mul_hi64") (typename uint64_t a, typename uint64_t b) { + typename __uint128_t aa = a; + typename __uint128_t bb = b; + return (aa * bb) >> 64; + } +$esc:("#endif") + +$esc:("#if defined(__OPENCL_VERSION__)") + static typename uint8_t $id:(funName' "mad_hi8") (typename uint8_t a, typename uint8_t b, typename uint8_t c) { + return mad_hi(a, b, c); + } + static typename uint16_t $id:(funName' "mad_hi16") (typename uint16_t a, typename uint16_t b, typename uint16_t c) { + return mad_hi(a, b, c); + } + static typename uint32_t $id:(funName' "mad_hi32") (typename uint32_t a, typename uint32_t b, typename uint32_t c) { + return mad_hi(a, b, c); + } + static typename uint64_t $id:(funName' "mad_hi64") (typename uint64_t a, typename uint64_t b, typename uint64_t c) { + return mad_hi(a, b, c); + } +$esc:("#else") + static typename uint8_t $id:(funName' "mad_hi8") (typename uint8_t a, typename uint8_t b, typename uint8_t c) { + return futrts_mul_hi8(a, b) + c; + } + static typename uint16_t $id:(funName' "mad_hi16") (typename uint16_t a, typename uint16_t b, typename uint16_t c) { + return futrts_mul_hi16(a, b) + c; + } + static typename uint32_t $id:(funName' "mad_hi32") (typename uint32_t a, typename uint32_t b, typename uint32_t c) { + return futrts_mul_hi32(a, b) + c; + } + static typename uint64_t $id:(funName' "mad_hi64") (typename uint64_t a, typename uint64_t b, typename uint64_t c) { + return futrts_mul_hi64(a, b) + c; + } +$esc:("#endif") + + +$esc:("#if defined(__OPENCL_VERSION__)") + static typename int32_t $id:(funName' "clz8") (typename int8_t x) { + return clz(x); + } + static typename int32_t $id:(funName' "clz16") (typename int16_t x) { + return clz(x); + } + static typename int32_t $id:(funName' "clz32") (typename int32_t x) { + return clz(x); + } + static typename int32_t $id:(funName' "clz64") (typename int64_t x) { + return clz(x); + } +$esc:("#elif defined(__CUDA_ARCH__)") + static typename int32_t $id:(funName' "clz8") (typename int8_t x) { + return __clz(zext_i8_i32(x))-24; + } + static typename int32_t $id:(funName' "clz16") (typename int16_t x) { + return __clz(zext_i16_i32(x))-16; + } + static typename int32_t $id:(funName' "clz32") (typename int32_t x) { + return __clz(x); + } + static typename int32_t $id:(funName' "clz64") (typename int64_t x) { + return __clzll(x); + } +$esc:("#else") + static typename int32_t $id:(funName' "clz8") (typename int8_t x) { + int n = 0; + int bits = sizeof(x) * 8; + for (int i = 0; i < bits; i++) { + if (x < 0) break; + n++; + x <<= 1; + } + return n; + } + static typename int32_t $id:(funName' "clz16") (typename int16_t x) { + int n = 0; + int bits = sizeof(x) * 8; + for (int i = 0; i < bits; i++) { + if (x < 0) break; + n++; + x <<= 1; + } + return n; + } + static typename int32_t $id:(funName' "clz32") (typename int32_t x) { + int n = 0; + int bits = sizeof(x) * 8; + for (int i = 0; i < bits; i++) { + if (x < 0) break; + n++; + x <<= 1; + } + return n; + } + static typename int32_t $id:(funName' "clz64") (typename int64_t x) { + int n = 0; + int bits = sizeof(x) * 8; + for (int i = 0; i < bits; i++) { + if (x < 0) break; + n++; + x <<= 1; + } + return n; + } +$esc:("#endif") + |] + +cFloat32Ops :: [C.Definition] +cFloat64Ops :: [C.Definition] +cFloatConvOps :: [C.Definition] +(cFloat32Ops, cFloat64Ops, cFloatConvOps) = + ( map ($Float32) mkOps + , map ($Float64) mkOps + , [ mkFPConvFF "fpconv" from to | + from <- [minBound..maxBound], + to <- [minBound..maxBound] ]) + where taggedF s Float32 = s ++ "32" + taggedF s Float64 = s ++ "64" + convOp s from to = s ++ "_" ++ pretty from ++ "_" ++ pretty to + + mkOps = [mkFDiv, mkFAdd, mkFSub, mkFMul, mkFMin, mkFMax, mkPow, mkCmpLt, mkCmpLe] ++ + map (mkFPConvIF "sitofp") [minBound..maxBound] ++ + map (mkFPConvUF "uitofp") [minBound..maxBound] ++ + map (flip $ mkFPConvFI "fptosi") [minBound..maxBound] ++ + map (flip $ mkFPConvFU "fptoui") [minBound..maxBound] + + mkFDiv = simpleFloatOp "fdiv" [C.cexp|x / y|] + mkFAdd = simpleFloatOp "fadd" [C.cexp|x + y|] + mkFSub = simpleFloatOp "fsub" [C.cexp|x - y|] + mkFMul = simpleFloatOp "fmul" [C.cexp|x * y|] + mkFMin = simpleFloatOp "fmin" [C.cexp|fmin(x, y)|] + mkFMax = simpleFloatOp "fmax" [C.cexp|fmax(x, y)|] + mkCmpLt = floatCmpOp "cmplt" [C.cexp|x < y|] + mkCmpLe = floatCmpOp "cmple" [C.cexp|x <= y|] + + mkPow Float32 = + [C.cedecl|static inline float fpow32(float x, float y) { return pow(x, y); }|] + mkPow Float64 = + [C.cedecl|static inline double fpow64(double x, double y) { return pow(x, y); }|] + + mkFPConv from_f to_f s from_t to_t = + [C.cedecl|static inline $ty:to_ct + $id:(convOp s from_t to_t)($ty:from_ct x) { return ($ty:to_ct)x;} |] + where from_ct = from_f from_t + to_ct = to_f to_t + + mkFPConvFF = mkFPConv floatTypeToCType floatTypeToCType + mkFPConvFI = mkFPConv floatTypeToCType intTypeToCType + mkFPConvIF = mkFPConv intTypeToCType floatTypeToCType + mkFPConvFU = mkFPConv floatTypeToCType uintTypeToCType + mkFPConvUF = mkFPConv uintTypeToCType floatTypeToCType + + simpleFloatOp s e t = + [C.cedecl|static inline $ty:ct $id:(taggedF s t)($ty:ct x, $ty:ct y) { return $exp:e; }|] + where ct = floatTypeToCType t + floatCmpOp s e t = + [C.cedecl|static inline typename bool $id:(taggedF s t)($ty:ct x, $ty:ct y) { return $exp:e; }|] + where ct = floatTypeToCType t + +cFloat32Funs :: [C.Definition] +cFloat32Funs = [C.cunit| + static inline float $id:(funName' "log32")(float x) { + return log(x); + } + + static inline float $id:(funName' "log2_32")(float x) { + return log2(x); + } + + static inline float $id:(funName' "log10_32")(float x) { + return log10(x); + } + + static inline float $id:(funName' "sqrt32")(float x) { + return sqrt(x); + } + + static inline float $id:(funName' "exp32")(float x) { + return exp(x); + } + + static inline float $id:(funName' "cos32")(float x) { + return cos(x); + } + + static inline float $id:(funName' "sin32")(float x) { + return sin(x); + } + + static inline float $id:(funName' "tan32")(float x) { + return tan(x); + } + + static inline float $id:(funName' "acos32")(float x) { + return acos(x); + } + + static inline float $id:(funName' "asin32")(float x) { + return asin(x); + } + + static inline float $id:(funName' "atan32")(float x) { + return atan(x); + } + + static inline float $id:(funName' "cosh32")(float x) { + return cosh(x); + } + + static inline float $id:(funName' "sinh32")(float x) { + return sinh(x); + } + + static inline float $id:(funName' "tanh32")(float x) { + return tanh(x); + } + + static inline float $id:(funName' "acosh32")(float x) { + return acosh(x); + } + + static inline float $id:(funName' "asinh32")(float x) { + return asinh(x); + } + + static inline float $id:(funName' "atanh32")(float x) { + return atanh(x); + } + + static inline float $id:(funName' "atan2_32")(float x, float y) { + return atan2(x,y); + } + + static inline float $id:(funName' "gamma32")(float x) { + return tgamma(x); + } + + static inline float $id:(funName' "lgamma32")(float x) { + return lgamma(x); + } + + static inline typename bool $id:(funName' "isnan32")(float x) { + return isnan(x); + } + + static inline typename bool $id:(funName' "isinf32")(float x) { + return isinf(x); + } + + static inline typename int32_t $id:(funName' "to_bits32")(float x) { + union { + float f; + typename int32_t t; + } p; + p.f = x; + return p.t; + } + + static inline float $id:(funName' "from_bits32")(typename int32_t x) { + union { + typename int32_t f; + float t; + } p; + p.f = x; + return p.t; + } + +$esc:("#ifdef __OPENCL_VERSION__") + static inline float fmod32(float x, float y) { + return fmod(x, y); + } + static inline float $id:(funName' "round32")(float x) { + return rint(x); + } + static inline float $id:(funName' "floor32")(float x) { + return floor(x); + } + static inline float $id:(funName' "ceil32")(float x) { + return ceil(x); + } + static inline float $id:(funName' "lerp32")(float v0, float v1, float t) { + return mix(v0, v1, t); + } + static inline float $id:(funName' "mad32")(float a, float b, float c) { + return mad(a,b,c); + } + static inline float $id:(funName' "fma32")(float a, float b, float c) { + return fma(a,b,c); + } +$esc:("#else") + static inline float fmod32(float x, float y) { + return fmodf(x, y); + } + static inline float $id:(funName' "round32")(float x) { + return rintf(x); + } + static inline float $id:(funName' "floor32")(float x) { + return floorf(x); + } + static inline float $id:(funName' "ceil32")(float x) { + return ceilf(x); + } + static inline float $id:(funName' "lerp32")(float v0, float v1, float t) { + return v0 + (v1-v0)*t; + } + static inline float $id:(funName' "mad32")(float a, float b, float c) { + return a*b+c; + } + static inline float $id:(funName' "fma32")(float a, float b, float c) { + return fmaf(a,b,c); + } +$esc:("#endif") +|] + +cFloat64Funs :: [C.Definition] +cFloat64Funs = [C.cunit| + static inline double $id:(funName' "log64")(double x) { + return log(x); + } + + static inline double $id:(funName' "log2_64")(double x) { + return log2(x); + } + + static inline double $id:(funName' "log10_64")(double x) { + return log10(x); + } + + static inline double $id:(funName' "sqrt64")(double x) { + return sqrt(x); + } + + static inline double $id:(funName' "exp64")(double x) { + return exp(x); + } + + static inline double $id:(funName' "cos64")(double x) { + return cos(x); + } + + static inline double $id:(funName' "sin64")(double x) { + return sin(x); + } + + static inline double $id:(funName' "tan64")(double x) { + return tan(x); + } + + static inline double $id:(funName' "acos64")(double x) { + return acos(x); + } + + static inline double $id:(funName' "asin64")(double x) { + return asin(x); + } + + static inline double $id:(funName' "atan64")(double x) { + return atan(x); + } + + static inline double $id:(funName' "cosh64")(double x) { + return cosh(x); + } + + static inline double $id:(funName' "sinh64")(double x) { + return sinh(x); + } + + static inline double $id:(funName' "tanh64")(double x) { + return tanh(x); + } + + static inline double $id:(funName' "acosh64")(double x) { + return acosh(x); + } + + static inline double $id:(funName' "asinh64")(double x) { + return asinh(x); + } + + static inline double $id:(funName' "atanh64")(double x) { + return atanh(x); + } + + static inline double $id:(funName' "atan2_64")(double x, double y) { + return atan2(x,y); + } + + static inline double $id:(funName' "gamma64")(double x) { + return tgamma(x); + } + + static inline double $id:(funName' "lgamma64")(double x) { + return lgamma(x); + } + + static inline double $id:(funName' "fma64")(double a, double b, double c) { + return fma(a,b,c); + } + + static inline double $id:(funName' "round64")(double x) { + return rint(x); + } + + static inline double $id:(funName' "ceil64")(double x) { + return ceil(x); + } + + static inline double $id:(funName' "floor64")(double x) { + return floor(x); + } + + static inline typename bool $id:(funName' "isnan64")(double x) { + return isnan(x); + } + + static inline typename bool $id:(funName' "isinf64")(double x) { + return isinf(x); + } + + static inline typename int64_t $id:(funName' "to_bits64")(double x) { + union { + double f; + typename int64_t t; + } p; + p.f = x; + return p.t; + } + + static inline double $id:(funName' "from_bits64")(typename int64_t x) { + union { + typename int64_t f; + double t; + } p; + p.f = x; + return p.t; + } + + static inline double fmod64(double x, double y) { + return fmod(x, y); + } + +$esc:("#ifdef __OPENCL_VERSION__") + static inline double $id:(funName' "lerp64")(double v0, double v1, double t) { + return mix(v0, v1, t); + } + static inline double $id:(funName' "mad64")(double a, double b, double c) { + return mad(a,b,c); + } +$esc:("#else") + static inline double $id:(funName' "lerp64")(double v0, double v1, double t) { + return v0 + (v1-v0)*t; + } + static inline double $id:(funName' "mad64")(double a, double b, double c) { + return a*b+c; + } +$esc:("#endif") +|] diff --git a/src/Futhark/CodeGen/Backends/SimpleRepresentation.hs b/src/Futhark/CodeGen/Backends/SimpleRepresentation.hs deleted file mode 100644 --- a/src/Futhark/CodeGen/Backends/SimpleRepresentation.hs +++ /dev/null @@ -1,758 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} --- | Simple C runtime representation. -module Futhark.CodeGen.Backends.SimpleRepresentation - ( tupleField - , funName - , defaultMemBlockType - , primTypeToCType - , signedPrimTypeToCType - - -- * Primitive value operations - , cIntOps - , cFloat32Ops, cFloat32Funs - , cFloat64Ops, cFloat64Funs - , cFloatConvOps - ) - where - -import qualified Language.C.Syntax as C -import qualified Language.C.Quote.C as C - -import Futhark.CodeGen.ImpCode -import Futhark.Util.Pretty (prettyOneLine) -import Futhark.Util (zEncodeString) - --- | The C type corresponding to a signed integer type. -intTypeToCType :: IntType -> C.Type -intTypeToCType Int8 = [C.cty|typename int8_t|] -intTypeToCType Int16 = [C.cty|typename int16_t|] -intTypeToCType Int32 = [C.cty|typename int32_t|] -intTypeToCType Int64 = [C.cty|typename int64_t|] - --- | The C type corresponding to an unsigned integer type. -uintTypeToCType :: IntType -> C.Type -uintTypeToCType Int8 = [C.cty|typename uint8_t|] -uintTypeToCType Int16 = [C.cty|typename uint16_t|] -uintTypeToCType Int32 = [C.cty|typename uint32_t|] -uintTypeToCType Int64 = [C.cty|typename uint64_t|] - --- | The C type corresponding to a float type. -floatTypeToCType :: FloatType -> C.Type -floatTypeToCType Float32 = [C.cty|float|] -floatTypeToCType Float64 = [C.cty|double|] - --- | The C type corresponding to a primitive type. Integers are --- assumed to be unsigned. -primTypeToCType :: PrimType -> C.Type -primTypeToCType (IntType t) = intTypeToCType t -primTypeToCType (FloatType t) = floatTypeToCType t -primTypeToCType Bool = [C.cty|typename bool|] -primTypeToCType Cert = [C.cty|typename bool|] - --- | The C type corresponding to a primitive type. Integers are --- assumed to have the specified sign. -signedPrimTypeToCType :: Signedness -> PrimType -> C.Type -signedPrimTypeToCType TypeUnsigned (IntType t) = uintTypeToCType t -signedPrimTypeToCType TypeDirect (IntType t) = intTypeToCType t -signedPrimTypeToCType _ t = primTypeToCType t - --- | @tupleField i@ is the name of field number @i@ in a tuple. -tupleField :: Int -> String -tupleField i = "v" ++ show i - --- | @funName f@ is the name of the C function corresponding to --- the Futhark function @f@. -funName :: Name -> String -funName = ("futrts_"++) . zEncodeString . nameToString - -funName' :: String -> String -funName' = funName . nameFromString - --- | The type of memory blocks in the default memory space. -defaultMemBlockType :: C.Type -defaultMemBlockType = [C.cty|char*|] - -cIntOps :: [C.Definition] -cIntOps = concatMap (`map` [minBound..maxBound]) ops - ++ cIntPrimFuns - where ops = [mkAdd, mkSub, mkMul, - mkUDiv, mkUMod, - mkSDiv, mkSMod, - mkSQuot, mkSRem, - mkSMin, mkUMin, - mkSMax, mkUMax, - mkShl, mkLShr, mkAShr, - mkAnd, mkOr, mkXor, - mkUlt, mkUle, mkSlt, mkSle, - mkPow, - mkIToB, mkBToI - ] ++ - map mkSExt [minBound..maxBound] ++ - map mkZExt [minBound..maxBound] - - taggedI s Int8 = s ++ "8" - taggedI s Int16 = s ++ "16" - taggedI s Int32 = s ++ "32" - taggedI s Int64 = s ++ "64" - - -- Use unsigned types for add/sub/mul so we can do - -- well-defined overflow. - mkAdd = simpleUintOp "add" [C.cexp|x + y|] - mkSub = simpleUintOp "sub" [C.cexp|x - y|] - mkMul = simpleUintOp "mul" [C.cexp|x * y|] - mkUDiv = simpleUintOp "udiv" [C.cexp|x / y|] - mkUMod = simpleUintOp "umod" [C.cexp|x % y|] - mkUMax = simpleUintOp "umax" [C.cexp|x < y ? y : x|] - mkUMin = simpleUintOp "umin" [C.cexp|x < y ? x : y|] - - mkSDiv t = - let ct = intTypeToCType t - in [C.cedecl|static inline $ty:ct $id:(taggedI "sdiv" t)($ty:ct x, $ty:ct y) { - $ty:ct q = x / y; - $ty:ct r = x % y; - return q - - (((r != 0) && ((r < 0) != (y < 0))) ? 1 : 0); - }|] - mkSMod t = - let ct = intTypeToCType t - in [C.cedecl|static inline $ty:ct $id:(taggedI "smod" t)($ty:ct x, $ty:ct y) { - $ty:ct r = x % y; - return r + - ((r == 0 || (x > 0 && y > 0) || (x < 0 && y < 0)) ? 0 : y); - }|] - - mkSQuot = simpleIntOp "squot" [C.cexp|x / y|] - mkSRem = simpleIntOp "srem" [C.cexp|x % y|] - mkSMax = simpleIntOp "smax" [C.cexp|x < y ? y : x|] - mkSMin = simpleIntOp "smin" [C.cexp|x < y ? x : y|] - mkShl = simpleUintOp "shl" [C.cexp|x << y|] - mkLShr = simpleUintOp "lshr" [C.cexp|x >> y|] - mkAShr = simpleIntOp "ashr" [C.cexp|x >> y|] - mkAnd = simpleUintOp "and" [C.cexp|x & y|] - mkOr = simpleUintOp "or" [C.cexp|x | y|] - mkXor = simpleUintOp "xor" [C.cexp|x ^ y|] - mkUlt = uintCmpOp "ult" [C.cexp|x < y|] - mkUle = uintCmpOp "ule" [C.cexp|x <= y|] - mkSlt = intCmpOp "slt" [C.cexp|x < y|] - mkSle = intCmpOp "sle" [C.cexp|x <= y|] - - -- We define some operations as macros rather than functions, - -- because this allows us to use them as constant expressions - -- in things like array sizes and static initialisers. - macro name rhs = - [C.cedecl|$esc:("#define " ++ name ++ "(x) (" ++ prettyOneLine rhs ++ ")")|] - - mkPow t = - let ct = intTypeToCType t - in [C.cedecl|static inline $ty:ct $id:(taggedI "pow" t)($ty:ct x, $ty:ct y) { - $ty:ct res = 1, rem = y; - while (rem != 0) { - if (rem & 1) { - res *= x; - } - rem >>= 1; - x *= x; - } - return res; - }|] - - mkSExt from_t to_t = macro name [C.cexp|($ty:to_ct)(($ty:from_ct)x)|] - where name = "sext_"++pretty from_t++"_"++pretty to_t - from_ct = intTypeToCType from_t - to_ct = intTypeToCType to_t - - mkZExt from_t to_t = macro name [C.cexp|($ty:to_ct)(($ty:from_ct)x)|] - where name = "zext_"++pretty from_t++"_"++pretty to_t - from_ct = uintTypeToCType from_t - to_ct = uintTypeToCType to_t - - mkBToI to_t = - [C.cedecl|static inline $ty:to_ct - $id:name($ty:from_ct x) { return x; } |] - where name = "btoi_bool_"++pretty to_t - from_ct = primTypeToCType Bool - to_ct = intTypeToCType to_t - - mkIToB from_t = - [C.cedecl|static inline $ty:to_ct - $id:name($ty:from_ct x) { return x; } |] - where name = "itob_"++pretty from_t++"_bool" - to_ct = primTypeToCType Bool - from_ct = intTypeToCType from_t - - simpleUintOp s e t = - [C.cedecl|static inline $ty:ct $id:(taggedI s t)($ty:ct x, $ty:ct y) { return $exp:e; }|] - where ct = uintTypeToCType t - simpleIntOp s e t = - [C.cedecl|static inline $ty:ct $id:(taggedI s t)($ty:ct x, $ty:ct y) { return $exp:e; }|] - where ct = intTypeToCType t - intCmpOp s e t = - [C.cedecl|static inline typename bool $id:(taggedI s t)($ty:ct x, $ty:ct y) { return $exp:e; }|] - where ct = intTypeToCType t - uintCmpOp s e t = - [C.cedecl|static inline typename bool $id:(taggedI s t)($ty:ct x, $ty:ct y) { return $exp:e; }|] - where ct = uintTypeToCType t - -cIntPrimFuns :: [C.Definition] -cIntPrimFuns = - [C.cunit| -$esc:("#if defined(__OPENCL_VERSION__)") - static typename int32_t $id:(funName' "popc8") (typename int8_t x) { - return popcount(x); - } - static typename int32_t $id:(funName' "popc16") (typename int16_t x) { - return popcount(x); - } - static typename int32_t $id:(funName' "popc32") (typename int32_t x) { - return popcount(x); - } - static typename int32_t $id:(funName' "popc64") (typename int64_t x) { - return popcount(x); - } -$esc:("#elif defined(__CUDA_ARCH__)") - static typename int32_t $id:(funName' "popc8") (typename int8_t x) { - return __popc(zext_i8_i32(x)); - } - static typename int32_t $id:(funName' "popc16") (typename int16_t x) { - return __popc(zext_i16_i32(x)); - } - static typename int32_t $id:(funName' "popc32") (typename int32_t x) { - return __popc(x); - } - static typename int32_t $id:(funName' "popc64") (typename int64_t x) { - return __popcll(x); - } -$esc:("#else") - static typename int32_t $id:(funName' "popc8") (typename int8_t x) { - int c = 0; - for (; x; ++c) { - x &= x - 1; - } - return c; - } - static typename int32_t $id:(funName' "popc16") (typename int16_t x) { - int c = 0; - for (; x; ++c) { - x &= x - 1; - } - return c; - } - static typename int32_t $id:(funName' "popc32") (typename int32_t x) { - int c = 0; - for (; x; ++c) { - x &= x - 1; - } - return c; - } - static typename int32_t $id:(funName' "popc64") (typename int64_t x) { - int c = 0; - for (; x; ++c) { - x &= x - 1; - } - return c; - } -$esc:("#endif") - -$esc:("#if defined(__OPENCL_VERSION__)") - static typename uint8_t $id:(funName' "mul_hi8") (typename uint8_t a, typename uint8_t b) { - return mul_hi(a, b); - } - static typename uint16_t $id:(funName' "mul_hi16") (typename uint16_t a, typename uint16_t b) { - return mul_hi(a, b); - } - static typename uint32_t $id:(funName' "mul_hi32") (typename uint32_t a, typename uint32_t b) { - return mul_hi(a, b); - } - static typename uint64_t $id:(funName' "mul_hi64") (typename uint64_t a, typename uint64_t b) { - return mul_hi(a, b); - } -$esc:("#elif defined(__CUDA_ARCH__)") - static typename uint8_t $id:(funName' "mul_hi8") (typename uint8_t a, typename uint8_t b) { - typename uint16_t aa = a; - typename uint16_t bb = b; - return (aa * bb) >> 8; - } - static typename uint16_t $id:(funName' "mul_hi16") (typename uint16_t a, typename uint16_t b) { - typename uint32_t aa = a; - typename uint32_t bb = b; - return (aa * bb) >> 16; - } - static typename uint32_t $id:(funName' "mul_hi32") (typename uint32_t a, typename uint32_t b) { - return mulhi(a, b); - } - static typename uint64_t $id:(funName' "mul_hi64") (typename uint64_t a, typename uint64_t b) { - return mul64hi(a, b); - } -$esc:("#else") - static typename uint8_t $id:(funName' "mul_hi8") (typename uint8_t a, typename uint8_t b) { - typename uint16_t aa = a; - typename uint16_t bb = b; - return (aa * bb) >> 8; - } - static typename uint16_t $id:(funName' "mul_hi16") (typename uint16_t a, typename uint16_t b) { - typename uint32_t aa = a; - typename uint32_t bb = b; - return (aa * bb) >> 16; - } - static typename uint32_t $id:(funName' "mul_hi32") (typename uint32_t a, typename uint32_t b) { - typename uint64_t aa = a; - typename uint64_t bb = b; - return (aa * bb) >> 32; - } - static typename uint64_t $id:(funName' "mul_hi64") (typename uint64_t a, typename uint64_t b) { - typename __uint128_t aa = a; - typename __uint128_t bb = b; - return (aa * bb) >> 64; - } -$esc:("#endif") - -$esc:("#if defined(__OPENCL_VERSION__)") - static typename uint8_t $id:(funName' "mad_hi8") (typename uint8_t a, typename uint8_t b, typename uint8_t c) { - return mad_hi(a, b, c); - } - static typename uint16_t $id:(funName' "mad_hi16") (typename uint16_t a, typename uint16_t b, typename uint16_t c) { - return mad_hi(a, b, c); - } - static typename uint32_t $id:(funName' "mad_hi32") (typename uint32_t a, typename uint32_t b, typename uint32_t c) { - return mad_hi(a, b, c); - } - static typename uint64_t $id:(funName' "mad_hi64") (typename uint64_t a, typename uint64_t b, typename uint64_t c) { - return mad_hi(a, b, c); - } -$esc:("#else") - static typename uint8_t $id:(funName' "mad_hi8") (typename uint8_t a, typename uint8_t b, typename uint8_t c) { - return futrts_mul_hi8(a, b) + c; - } - static typename uint16_t $id:(funName' "mad_hi16") (typename uint16_t a, typename uint16_t b, typename uint16_t c) { - return futrts_mul_hi16(a, b) + c; - } - static typename uint32_t $id:(funName' "mad_hi32") (typename uint32_t a, typename uint32_t b, typename uint32_t c) { - return futrts_mul_hi32(a, b) + c; - } - static typename uint64_t $id:(funName' "mad_hi64") (typename uint64_t a, typename uint64_t b, typename uint64_t c) { - return futrts_mul_hi64(a, b) + c; - } -$esc:("#endif") - - -$esc:("#if defined(__OPENCL_VERSION__)") - static typename int32_t $id:(funName' "clz8") (typename int8_t x) { - return clz(x); - } - static typename int32_t $id:(funName' "clz16") (typename int16_t x) { - return clz(x); - } - static typename int32_t $id:(funName' "clz32") (typename int32_t x) { - return clz(x); - } - static typename int32_t $id:(funName' "clz64") (typename int64_t x) { - return clz(x); - } -$esc:("#elif defined(__CUDA_ARCH__)") - static typename int32_t $id:(funName' "clz8") (typename int8_t x) { - return __clz(zext_i8_i32(x))-24; - } - static typename int32_t $id:(funName' "clz16") (typename int16_t x) { - return __clz(zext_i16_i32(x))-16; - } - static typename int32_t $id:(funName' "clz32") (typename int32_t x) { - return __clz(x); - } - static typename int32_t $id:(funName' "clz64") (typename int64_t x) { - return __clzll(x); - } -$esc:("#else") - static typename int32_t $id:(funName' "clz8") (typename int8_t x) { - int n = 0; - int bits = sizeof(x) * 8; - for (int i = 0; i < bits; i++) { - if (x < 0) break; - n++; - x <<= 1; - } - return n; - } - static typename int32_t $id:(funName' "clz16") (typename int16_t x) { - int n = 0; - int bits = sizeof(x) * 8; - for (int i = 0; i < bits; i++) { - if (x < 0) break; - n++; - x <<= 1; - } - return n; - } - static typename int32_t $id:(funName' "clz32") (typename int32_t x) { - int n = 0; - int bits = sizeof(x) * 8; - for (int i = 0; i < bits; i++) { - if (x < 0) break; - n++; - x <<= 1; - } - return n; - } - static typename int32_t $id:(funName' "clz64") (typename int64_t x) { - int n = 0; - int bits = sizeof(x) * 8; - for (int i = 0; i < bits; i++) { - if (x < 0) break; - n++; - x <<= 1; - } - return n; - } -$esc:("#endif") - |] - -cFloat32Ops :: [C.Definition] -cFloat64Ops :: [C.Definition] -cFloatConvOps :: [C.Definition] -(cFloat32Ops, cFloat64Ops, cFloatConvOps) = - ( map ($Float32) mkOps - , map ($Float64) mkOps - , [ mkFPConvFF "fpconv" from to | - from <- [minBound..maxBound], - to <- [minBound..maxBound] ]) - where taggedF s Float32 = s ++ "32" - taggedF s Float64 = s ++ "64" - convOp s from to = s ++ "_" ++ pretty from ++ "_" ++ pretty to - - mkOps = [mkFDiv, mkFAdd, mkFSub, mkFMul, mkFMin, mkFMax, mkPow, mkCmpLt, mkCmpLe] ++ - map (mkFPConvIF "sitofp") [minBound..maxBound] ++ - map (mkFPConvUF "uitofp") [minBound..maxBound] ++ - map (flip $ mkFPConvFI "fptosi") [minBound..maxBound] ++ - map (flip $ mkFPConvFU "fptoui") [minBound..maxBound] - - mkFDiv = simpleFloatOp "fdiv" [C.cexp|x / y|] - mkFAdd = simpleFloatOp "fadd" [C.cexp|x + y|] - mkFSub = simpleFloatOp "fsub" [C.cexp|x - y|] - mkFMul = simpleFloatOp "fmul" [C.cexp|x * y|] - mkFMin = simpleFloatOp "fmin" [C.cexp|fmin(x, y)|] - mkFMax = simpleFloatOp "fmax" [C.cexp|fmax(x, y)|] - mkCmpLt = floatCmpOp "cmplt" [C.cexp|x < y|] - mkCmpLe = floatCmpOp "cmple" [C.cexp|x <= y|] - - mkPow Float32 = - [C.cedecl|static inline float fpow32(float x, float y) { return pow(x, y); }|] - mkPow Float64 = - [C.cedecl|static inline double fpow64(double x, double y) { return pow(x, y); }|] - - mkFPConv from_f to_f s from_t to_t = - [C.cedecl|static inline $ty:to_ct - $id:(convOp s from_t to_t)($ty:from_ct x) { return ($ty:to_ct)x;} |] - where from_ct = from_f from_t - to_ct = to_f to_t - - mkFPConvFF = mkFPConv floatTypeToCType floatTypeToCType - mkFPConvFI = mkFPConv floatTypeToCType intTypeToCType - mkFPConvIF = mkFPConv intTypeToCType floatTypeToCType - mkFPConvFU = mkFPConv floatTypeToCType uintTypeToCType - mkFPConvUF = mkFPConv uintTypeToCType floatTypeToCType - - simpleFloatOp s e t = - [C.cedecl|static inline $ty:ct $id:(taggedF s t)($ty:ct x, $ty:ct y) { return $exp:e; }|] - where ct = floatTypeToCType t - floatCmpOp s e t = - [C.cedecl|static inline typename bool $id:(taggedF s t)($ty:ct x, $ty:ct y) { return $exp:e; }|] - where ct = floatTypeToCType t - -cFloat32Funs :: [C.Definition] -cFloat32Funs = [C.cunit| - static inline float $id:(funName' "log32")(float x) { - return log(x); - } - - static inline float $id:(funName' "log2_32")(float x) { - return log2(x); - } - - static inline float $id:(funName' "log10_32")(float x) { - return log10(x); - } - - static inline float $id:(funName' "sqrt32")(float x) { - return sqrt(x); - } - - static inline float $id:(funName' "exp32")(float x) { - return exp(x); - } - - static inline float $id:(funName' "cos32")(float x) { - return cos(x); - } - - static inline float $id:(funName' "sin32")(float x) { - return sin(x); - } - - static inline float $id:(funName' "tan32")(float x) { - return tan(x); - } - - static inline float $id:(funName' "acos32")(float x) { - return acos(x); - } - - static inline float $id:(funName' "asin32")(float x) { - return asin(x); - } - - static inline float $id:(funName' "atan32")(float x) { - return atan(x); - } - - static inline float $id:(funName' "cosh32")(float x) { - return cosh(x); - } - - static inline float $id:(funName' "sinh32")(float x) { - return sinh(x); - } - - static inline float $id:(funName' "tanh32")(float x) { - return tanh(x); - } - - static inline float $id:(funName' "acosh32")(float x) { - return acosh(x); - } - - static inline float $id:(funName' "asinh32")(float x) { - return asinh(x); - } - - static inline float $id:(funName' "atanh32")(float x) { - return atanh(x); - } - - static inline float $id:(funName' "atan2_32")(float x, float y) { - return atan2(x,y); - } - - static inline float $id:(funName' "gamma32")(float x) { - return tgamma(x); - } - - static inline float $id:(funName' "lgamma32")(float x) { - return lgamma(x); - } - - static inline typename bool $id:(funName' "isnan32")(float x) { - return isnan(x); - } - - static inline typename bool $id:(funName' "isinf32")(float x) { - return isinf(x); - } - - static inline typename int32_t $id:(funName' "to_bits32")(float x) { - union { - float f; - typename int32_t t; - } p; - p.f = x; - return p.t; - } - - static inline float $id:(funName' "from_bits32")(typename int32_t x) { - union { - typename int32_t f; - float t; - } p; - p.f = x; - return p.t; - } - -$esc:("#ifdef __OPENCL_VERSION__") - static inline float fmod32(float x, float y) { - return fmod(x, y); - } - static inline float $id:(funName' "round32")(float x) { - return rint(x); - } - static inline float $id:(funName' "floor32")(float x) { - return floor(x); - } - static inline float $id:(funName' "ceil32")(float x) { - return ceil(x); - } - static inline float $id:(funName' "lerp32")(float v0, float v1, float t) { - return mix(v0, v1, t); - } - static inline float $id:(funName' "mad32")(float a, float b, float c) { - return mad(a,b,c); - } - static inline float $id:(funName' "fma32")(float a, float b, float c) { - return fma(a,b,c); - } -$esc:("#else") - static inline float fmod32(float x, float y) { - return fmodf(x, y); - } - static inline float $id:(funName' "round32")(float x) { - return rintf(x); - } - static inline float $id:(funName' "floor32")(float x) { - return floorf(x); - } - static inline float $id:(funName' "ceil32")(float x) { - return ceilf(x); - } - static inline float $id:(funName' "lerp32")(float v0, float v1, float t) { - return v0 + (v1-v0)*t; - } - static inline float $id:(funName' "mad32")(float a, float b, float c) { - return a*b+c; - } - static inline float $id:(funName' "fma32")(float a, float b, float c) { - return fmaf(a,b,c); - } -$esc:("#endif") -|] - -cFloat64Funs :: [C.Definition] -cFloat64Funs = [C.cunit| - static inline double $id:(funName' "log64")(double x) { - return log(x); - } - - static inline double $id:(funName' "log2_64")(double x) { - return log2(x); - } - - static inline double $id:(funName' "log10_64")(double x) { - return log10(x); - } - - static inline double $id:(funName' "sqrt64")(double x) { - return sqrt(x); - } - - static inline double $id:(funName' "exp64")(double x) { - return exp(x); - } - - static inline double $id:(funName' "cos64")(double x) { - return cos(x); - } - - static inline double $id:(funName' "sin64")(double x) { - return sin(x); - } - - static inline double $id:(funName' "tan64")(double x) { - return tan(x); - } - - static inline double $id:(funName' "acos64")(double x) { - return acos(x); - } - - static inline double $id:(funName' "asin64")(double x) { - return asin(x); - } - - static inline double $id:(funName' "atan64")(double x) { - return atan(x); - } - - static inline double $id:(funName' "cosh64")(double x) { - return cosh(x); - } - - static inline double $id:(funName' "sinh64")(double x) { - return sinh(x); - } - - static inline double $id:(funName' "tanh64")(double x) { - return tanh(x); - } - - static inline double $id:(funName' "acosh64")(double x) { - return acosh(x); - } - - static inline double $id:(funName' "asinh64")(double x) { - return asinh(x); - } - - static inline double $id:(funName' "atanh64")(double x) { - return atanh(x); - } - - static inline double $id:(funName' "atan2_64")(double x, double y) { - return atan2(x,y); - } - - static inline double $id:(funName' "gamma64")(double x) { - return tgamma(x); - } - - static inline double $id:(funName' "lgamma64")(double x) { - return lgamma(x); - } - - static inline double $id:(funName' "fma64")(double a, double b, double c) { - return fma(a,b,c); - } - - static inline double $id:(funName' "round64")(double x) { - return rint(x); - } - - static inline double $id:(funName' "ceil64")(double x) { - return ceil(x); - } - - static inline double $id:(funName' "floor64")(double x) { - return floor(x); - } - - static inline typename bool $id:(funName' "isnan64")(double x) { - return isnan(x); - } - - static inline typename bool $id:(funName' "isinf64")(double x) { - return isinf(x); - } - - static inline typename int64_t $id:(funName' "to_bits64")(double x) { - union { - double f; - typename int64_t t; - } p; - p.f = x; - return p.t; - } - - static inline double $id:(funName' "from_bits64")(typename int64_t x) { - union { - typename int64_t f; - double t; - } p; - p.f = x; - return p.t; - } - - static inline double fmod64(double x, double y) { - return fmod(x, y); - } - -$esc:("#ifdef __OPENCL_VERSION__") - static inline double $id:(funName' "lerp64")(double v0, double v1, double t) { - return mix(v0, v1, t); - } - static inline double $id:(funName' "mad64")(double a, double b, double c) { - return mad(a,b,c); - } -$esc:("#else") - static inline double $id:(funName' "lerp64")(double v0, double v1, double t) { - return v0 + (v1-v0)*t; - } - static inline double $id:(funName' "mad64")(double a, double b, double c) { - return a*b+c; - } -$esc:("#endif") -|] diff --git a/src/Futhark/CodeGen/ImpCode.hs b/src/Futhark/CodeGen/ImpCode.hs --- a/src/Futhark/CodeGen/ImpCode.hs +++ b/src/Futhark/CodeGen/ImpCode.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE Safe #-} -- | Imperative intermediate language used as a stepping stone in code generation. -- -- This is a generic representation parametrised on an extensible @@ -49,38 +50,43 @@ -- * Re-exports from other modules. , module Language.Futhark.Core - , module Futhark.Representation.Primitive + , module Futhark.IR.Primitive , module Futhark.Analysis.PrimExp - , module Futhark.Representation.Kernels.Sizes - , module Futhark.Representation.AST.Attributes.Names + , module Futhark.IR.Kernels.Sizes + , module Futhark.IR.Prop.Names ) where import Data.List (intersperse) -import Data.Loc import Data.Traversable import qualified Data.Map as M import Language.Futhark.Core -import Futhark.Representation.Primitive -import Futhark.Representation.AST.Syntax +import Futhark.IR.Primitive +import Futhark.IR.Syntax (SubExp(..), Space(..), SpaceId, ErrorMsg(..), ErrorMsgPart(..), errorMsgArgTypes) -import Futhark.Representation.AST.Attributes.Names -import Futhark.Representation.AST.Pretty () +import Futhark.IR.Prop.Names +import Futhark.IR.Pretty () import Futhark.Analysis.PrimExp import Futhark.Util.Pretty hiding (space) -import Futhark.Representation.Kernels.Sizes (Count(..)) +import Futhark.IR.Kernels.Sizes (Count(..)) +-- | The size of a memory block. type MemSize = SubExp + +-- | The size of an array. type DimSize = SubExp +-- | The type of a parameter. data Type = Scalar PrimType | Mem Space +-- | An ImpCode function parameter. data Param = MemParam VName Space | ScalarParam VName PrimType deriving (Show) +-- | The name of a parameter. paramName :: Param -> VName paramName (MemParam name _) = name paramName (ScalarParam name _) = name @@ -106,6 +112,10 @@ -- contain declarations of the names defined in 'constsDecl'. } +-- | Since the core language does not care for signedness, but the +-- source language does, entry point input/output information has +-- metadata for integer types (and arrays containing these) that +-- indicate whether they are really unsigned integers. data Signedness = TypeUnsigned | TypeDirect deriving (Eq, Show) @@ -153,12 +163,29 @@ -- ^ This many zeroes. deriving (Show) +-- | A block of imperative code. Parameterised by an 'Op', which +-- allows extensibility. Concrete uses of this type will instantiate +-- the type parameter with e.g. a construct for launching GPU kernels. data Code a = Skip + -- ^ No-op. Crucial for the 'Monoid' instance. | Code a :>>: Code a + -- ^ Statement composition. Crucial for the 'Semigroup' instance. | For VName IntType Exp (Code a) + -- ^ A for-loop iterating the given number of times. The + -- loop parameter starts counting from zero and will have + -- the given type. The bound is evaluated just once, + -- before the loop is entered. | While Exp (Code a) + -- ^ While loop. The conditional is (of course) + -- re-evaluated before every iteration of the loop. | DeclareMem VName Space + -- ^ Declare a memory block variable that will point to + -- memory in the given memory space. Note that this is + -- distinct from allocation. The memory block must be the + -- target of either an 'Allocate' or a 'SetMem' before it + -- can be used for reading or writing. | DeclareScalar VName Volatility PrimType + -- ^ Declare a scalar variable with an initially undefined value. | DeclareArray VName Space PrimType ArrayContents -- ^ Create an array containing the given values. The -- lifetime of the array will be the entire application. @@ -181,12 +208,24 @@ -- space, source, offset in source, offset space, number -- of bytes. | Write VName (Count Elements Exp) PrimType Space Volatility Exp + -- ^ @Write mem i t space vol v@ writes the value @v@ to + -- @mem@ offset by @i@ elements of type @t@. The + -- 'Space' argument is the memory space of @mem@ + -- (technically redundant, but convenient). Note that + -- /reading/ is done with an 'Exp' ('Index'). | SetScalar VName Exp + -- ^ Set a scalar variable. | SetMem VName VName Space -- ^ Must be in same space. | Call [VName] Name [Arg] + -- ^ Function call. The results are written to the + -- provided 'VName' variables. | If Exp (Code a) (Code a) + -- ^ Conditional execution. | Assert Exp (ErrorMsg Exp) (SrcLoc, [SrcLoc]) + -- ^ Assert that something must be true. Should it turn + -- out not to be true, then report a failure along with + -- the given error message. | Comment String (Code a) -- ^ Has the same semantics as the contained code, but -- the comment should show up in generated code for ease @@ -199,6 +238,7 @@ -- debugging. Code generators are free to ignore this -- statement. | Op a + -- ^ Perform an extensible operation. deriving (Show) -- | The volatility of a memory access or variable. Feel free to @@ -244,11 +284,19 @@ set (SetMem x y _) = namesFromList [x,y] set x = go set x +-- | The leaves of an 'Exp'. data ExpLeaf = ScalarVar VName + -- ^ A scalar variable. The type is stored in the + -- 'LeafExp' constructor itself. | SizeOf PrimType + -- ^ The size of a primitive type. | Index VName (Count Elements Exp) PrimType Space Volatility + -- ^ Reading a value from memory. The arguments have + -- the same meaning as with 'Write'. deriving (Eq, Show) +-- | A side-effect free expression whose execution will produce a +-- single primitive value. type Exp = PrimExp ExpLeaf -- | A function call argument. @@ -262,9 +310,11 @@ -- | Phantom type for a count of bytes. data Bytes +-- | This expression counts elements. elements :: Exp -> Count Elements Exp elements = Count +-- | This expression counts bytes. bytes :: Exp -> Count Bytes Exp bytes = Count @@ -274,13 +324,15 @@ withElemType (Count e) t = bytes $ ConvOpExp (SExt Int32 Int64) e * LeafExp (SizeOf t) (IntType Int64) +-- | Turn a 'VName' into a 'Imp.ScalarVar'. var :: VName -> PrimType -> Exp var = LeafExp . ScalarVar --- | Turn a 'VName' into a 'int32' 'Imp.ScalarVar'. +-- | Turn a 'VName' into a v'Int32' 'Imp.ScalarVar'. vi32 :: VName -> Exp vi32 = flip var $ IntType Int32 +-- | Concise wrapper for using 'Index'. index :: VName -> Count Elements Exp -> PrimType -> Space -> Volatility -> Exp index arr i t s vol = LeafExp (Index arr i t s vol) t diff --git a/src/Futhark/CodeGen/ImpCode/Kernels.hs b/src/Futhark/CodeGen/ImpCode/Kernels.hs --- a/src/Futhark/CodeGen/ImpCode/Kernels.hs +++ b/src/Futhark/CodeGen/ImpCode/Kernels.hs @@ -17,20 +17,25 @@ , Kernel (..) , KernelUse (..) , module Futhark.CodeGen.ImpCode - , module Futhark.Representation.Kernels.Sizes + , module Futhark.IR.Kernels.Sizes ) where import Futhark.CodeGen.ImpCode hiding (Function, Code) import qualified Futhark.CodeGen.ImpCode as Imp -import Futhark.Representation.Kernels.Sizes -import Futhark.Representation.AST.Pretty () +import Futhark.IR.Kernels.Sizes +import Futhark.IR.Pretty () import Futhark.Util.Pretty +-- | A program that calls kernels. type Program = Imp.Definitions HostOp + +-- | A function that calls kernels. type Function = Imp.Function HostOp + -- | Host-level code that can call kernels. type Code = Imp.Code HostOp + -- | Code inside a kernel. type KernelCode = Imp.Code KernelOp @@ -41,6 +46,7 @@ -- | An expression whose variables are kernel constants. type KernelConstExp = PrimExp KernelConst +-- | An operation that runs on the host (CPU). data HostOp = CallKernel Kernel | GetSize VName Name SizeClass | CmpSizeLe VName Name SizeClass Imp.Exp @@ -70,6 +76,9 @@ } deriving (Show) +-- | Information about a host-level variable that is used inside this +-- kernel. When generating the actual kernel code, this is used to +-- deduce which parameters are needed. data KernelUse = ScalarUse VName PrimType | MemoryUse VName | ConstUse VName KernelConstExp @@ -127,6 +136,7 @@ data Fence = FenceLocal | FenceGlobal deriving (Show) +-- | An operation that occurs within a kernel body. data KernelOp = GetGroupId VName Int | GetLocalId VName Int | GetLocalSize VName Int @@ -146,8 +156,9 @@ -- control flow or similar. deriving (Show) --- Atomic operations return the value stored before the update. --- This value is stored in the first VName. +-- | Atomic operations return the value stored before the update. +-- This old value is stored in the first 'VName'. The second 'VName' +-- is the memory block to update. The 'Exp' is the new value. data AtomicOp = AtomicAdd IntType VName VName (Count Elements Imp.Exp) Exp | AtomicFAdd FloatType VName VName (Count Elements Imp.Exp) Exp | AtomicSMax IntType VName VName (Count Elements Imp.Exp) Exp diff --git a/src/Futhark/CodeGen/ImpCode/OpenCL.hs b/src/Futhark/CodeGen/ImpCode/OpenCL.hs --- a/src/Futhark/CodeGen/ImpCode/OpenCL.hs +++ b/src/Futhark/CodeGen/ImpCode/OpenCL.hs @@ -19,14 +19,14 @@ , KernelTarget (..) , FailureMsg(..) , module Futhark.CodeGen.ImpCode - , module Futhark.Representation.Kernels.Sizes + , module Futhark.IR.Kernels.Sizes ) where import qualified Data.Map as M import Futhark.CodeGen.ImpCode hiding (Function, Code) -import Futhark.Representation.Kernels.Sizes +import Futhark.IR.Kernels.Sizes import qualified Futhark.CodeGen.ImpCode as Imp import Futhark.Util.Pretty diff --git a/src/Futhark/CodeGen/ImpGen.hs b/src/Futhark/CodeGen/ImpGen.hs --- a/src/Futhark/CodeGen/ImpGen.hs +++ b/src/Futhark/CodeGen/ImpGen.hs @@ -2,7 +2,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE Strict #-} -{-# LANGUAGE StrictData #-} +{-# LANGUAGE Trustworthy #-} module Futhark.CodeGen.ImpGen ( -- * Entry Points compileProg @@ -98,14 +98,14 @@ import Futhark.CodeGen.ImpCode (Count, Bytes, Elements, bytes, elements, withElemType) -import Futhark.Representation.Mem -import Futhark.Representation.SOACS (SOACS) -import qualified Futhark.Representation.Mem.IxFun as IxFun +import Futhark.IR.Mem +import Futhark.IR.SOACS (SOACS) +import qualified Futhark.IR.Mem.IxFun as IxFun import Futhark.Construct (fullSliceNum) import Futhark.MonadFreshNames import Futhark.Util --- | How to compile an 'Op'. +-- | How to compile an t'Op'. type OpCompiler lore r op = Pattern lore -> Op lore -> ImpM lore r op () -- | How to compile some 'Stms'. @@ -130,7 +130,7 @@ } -- | An operations set for which the expression compiler always --- returns 'CompileExp'. +-- returns 'defCompileExp'. defaultOperations :: (Mem lore, FreeIn op) => OpCompiler lore r op -> Operations lore r op defaultOperations opc = Operations { opsExpCompiler = defCompileExp @@ -241,7 +241,7 @@ -- Cannot be an KernelsMem scope because the index functions have -- the wrong leaves (VName instead of Imp.Exp). instance HasScope SOACS (ImpM lore r op) where - askScope = M.map (LetInfo . entryType) <$> gets stateVTable + askScope = gets $ M.map (LetName . entryType) . stateVTable where entryType (MemVar _ memEntry) = Mem (entryMemSpace memEntry) entryType (ArrayVar _ arrayEntry) = @@ -323,8 +323,8 @@ constsVTable = foldMap stmVtable where stmVtable (Let pat _ e) = foldMap (peVtable e) $ patternElements pat - peVtable e (PatElem name attr) = - M.singleton name $ memBoundToVarEntry (Just e) attr + peVtable e (PatElem name dec) = + M.singleton name $ memBoundToVarEntry (Just e) dec compileProg :: (Mem lore, FreeIn op, MonadFreshNames m) => r -> Operations lore r op -> Imp.Space @@ -366,7 +366,7 @@ compileInParam :: Mem lore => FParam lore -> ImpM lore r op (Either Imp.Param ArrayDecl) -compileInParam fparam = case paramAttr fparam of +compileInParam fparam = case paramDec fparam of MemPrim bt -> return $ Left $ Imp.ScalarParam name bt MemMem space -> @@ -378,7 +378,7 @@ data ArrayDecl = ArrayDecl VName PrimType MemLocation -fparamSizes :: Typed attr => Param attr -> S.Set VName +fparamSizes :: Typed dec => Param dec -> S.Set VName fparamSizes = S.fromList . subExpVars . arrayDims . paramType compileInParams :: Mem lore => @@ -393,7 +393,7 @@ summaries = M.fromList $ mapMaybe memSummary params where memSummary param - | MemMem space <- paramAttr param = + | MemMem space <- paramDec param = Just (paramName param, space) | otherwise = Nothing @@ -464,9 +464,9 @@ out <- imp $ newVName "scalar_out" tell ([Imp.ScalarParam out t], mempty) return (Imp.ScalarValue t ept out, ScalarDestination out) - mkParam (MemArray t shape _ attr) ept = do + mkParam (MemArray t shape _ dec) ept = do space <- asks envDefaultSpace - memout <- case attr of + memout <- case dec of ReturnsNewBlock _ x _ixfun -> do memout <- imp $ newVName "out_mem" tell ([Imp.MemParam memout space], @@ -518,12 +518,12 @@ compileStms (freeIn ses) bnds $ forM_ (zip dests ses) $ \(d, se) -> copyDWIMDest d [] se [] -compileBody' :: [Param attr] -> Body lore -> ImpM lore r op () +compileBody' :: [Param dec] -> Body lore -> ImpM lore r op () compileBody' params (Body _ bnds ses) = compileStms (freeIn ses) bnds $ forM_ (zip params ses) $ \(param, se) -> copyDWIM (paramName param) [] se [] -compileLoopBody :: Typed attr => [Param attr] -> Body lore -> ImpM lore r op () +compileLoopBody :: Typed dec => [Param dec] -> Body lore -> ImpM lore r op () compileLoopBody mergeparams (Body _ bnds ses) = do -- We cannot write the results to the merge parameters immediately, -- as some of the results may actually *be* merge parameters, and @@ -777,7 +777,7 @@ addFParams = mapM_ addFParam where addFParam fparam = addVar (paramName fparam) $ - memBoundToVarEntry Nothing $ noUniquenessReturns $ paramAttr fparam + memBoundToVarEntry Nothing $ noUniquenessReturns $ paramDec fparam -- | Another hack. addLoopVar :: VName -> IntType -> ImpM lore r op () @@ -835,19 +835,19 @@ , entryArrayElemType = bt } -infoAttr :: Mem lore => +infoDec :: Mem lore => NameInfo lore -> MemInfo SubExp NoUniqueness MemBind -infoAttr (LetInfo attr) = attr -infoAttr (FParamInfo attr) = noUniquenessReturns attr -infoAttr (LParamInfo attr) = attr -infoAttr (IndexInfo it) = MemPrim $ IntType it +infoDec (LetName dec) = dec +infoDec (FParamName dec) = noUniquenessReturns dec +infoDec (LParamName dec) = dec +infoDec (IndexName it) = MemPrim $ IntType it dInfo :: Mem lore => Maybe (Exp lore) -> VName -> NameInfo lore -> ImpM lore r op () dInfo e name info = do - let entry = memBoundToVarEntry e $ infoAttr info + let entry = memBoundToVarEntry e $ infoDec info case entry of MemVar _ entry' -> emit $ Imp.DeclareMem name $ entryMemSpace entry' diff --git a/src/Futhark/CodeGen/ImpGen/CUDA.hs b/src/Futhark/CodeGen/ImpGen/CUDA.hs --- a/src/Futhark/CodeGen/ImpGen/CUDA.hs +++ b/src/Futhark/CodeGen/ImpGen/CUDA.hs @@ -2,7 +2,7 @@ ( compileProg ) where -import Futhark.Representation.KernelsMem +import Futhark.IR.KernelsMem import qualified Futhark.CodeGen.ImpCode.OpenCL as OpenCL import qualified Futhark.CodeGen.ImpGen.Kernels as ImpGenKernels import Futhark.CodeGen.ImpGen.Kernels.ToOpenCL diff --git a/src/Futhark/CodeGen/ImpGen/Kernels.hs b/src/Futhark/CodeGen/ImpGen/Kernels.hs --- a/src/Futhark/CodeGen/ImpGen/Kernels.hs +++ b/src/Futhark/CodeGen/ImpGen/Kernels.hs @@ -20,7 +20,7 @@ import Futhark.Error import Futhark.MonadFreshNames -import Futhark.Representation.KernelsMem +import Futhark.IR.KernelsMem import qualified Futhark.CodeGen.ImpCode.Kernels as Imp import Futhark.CodeGen.ImpCode.Kernels (bytes) import Futhark.CodeGen.ImpGen hiding (compileProg) @@ -31,7 +31,7 @@ import Futhark.CodeGen.ImpGen.Kernels.SegScan import Futhark.CodeGen.ImpGen.Kernels.SegHist import Futhark.CodeGen.ImpGen.Kernels.Transpose -import qualified Futhark.Representation.Mem.IxFun as IxFun +import qualified Futhark.IR.Mem.IxFun as IxFun import Futhark.CodeGen.SetDefaultSpace import Futhark.Util.IntegralExp (quot, quotRoundingUp, IntegralExp) diff --git a/src/Futhark/CodeGen/ImpGen/Kernels/Base.hs b/src/Futhark/CodeGen/ImpGen/Kernels/Base.hs --- a/src/Futhark/CodeGen/ImpGen/Kernels/Base.hs +++ b/src/Futhark/CodeGen/ImpGen/Kernels/Base.hs @@ -44,8 +44,8 @@ import Futhark.Error import Futhark.MonadFreshNames import Futhark.Transform.Rename -import Futhark.Representation.KernelsMem -import qualified Futhark.Representation.Mem.IxFun as IxFun +import Futhark.IR.KernelsMem +import qualified Futhark.IR.Mem.IxFun as IxFun import qualified Futhark.CodeGen.ImpCode.Kernels as Imp import Futhark.CodeGen.ImpGen import Futhark.Util.IntegralExp (quotRoundingUp, quot, rem) @@ -460,13 +460,12 @@ | AtomicLocking (Locking -> DoAtomicUpdate lore r) -- ^ Requires explicit locking. --- | Is there an atomic 'BinOp' corresponding to this 'BinOp'? +-- | Is there an atomic t'BinOp' corresponding to this t'BinOp'? type AtomicBinOp = BinOp -> Maybe (VName -> VName -> Count Imp.Elements Imp.Exp -> Imp.Exp -> Imp.AtomicOp) --- | 'atomicUpdate', but where it is explicitly visible whether a --- locking strategy is necessary. +-- | Do an atomic update corresponding to a binary operator lambda. atomicUpdateLocking :: AtomicBinOp -> Lambda KernelsMem -> AtomicUpdate KernelsMem KernelEnv @@ -621,7 +620,7 @@ (run_loop <-- 0) -- | Horizontally fission a lambda that models a binary operator. -splitOp :: Attributes lore => Lambda lore -> Maybe [(BinOp, PrimType, VName, VName)] +splitOp :: ASTLore lore => Lambda lore -> Maybe [(BinOp, PrimType, VName, VName)] splitOp lam = mapM splitStm $ bodyResult $ lambdaBody lam where n = length $ lambdaReturnType lam splitStm (Var res) = do @@ -1430,12 +1429,15 @@ compileThreadResult _ pe (WriteReturns rws _arr dests) = do constants <- kernelConstants <$> askEnv rws' <- mapM toExp rws - forM_ dests $ \(is, e) -> do - is' <- mapM toExp is - let condInBounds i rw = 0 .<=. i .&&. i .<. rw + forM_ dests $ \(slice, e) -> do + slice' <- mapM (traverse toExp) slice + let condInBounds (DimFix i) rw = + 0 .<=. i .&&. i .<. rw + condInBounds (DimSlice i n s) rw = + 0 .<=. i .&&. i+n*s .<. rw write = foldl (.&&.) (kernelThreadActive constants) $ - zipWith condInBounds is' rws' - sWhen write $ copyDWIMFix (patElemName pe) (map (toExp' int32) is) e [] + zipWith condInBounds slice' rws' + sWhen write $ copyDWIM (patElemName pe) slice' e [] compileThreadResult _ _ TileReturns{} = compilerBugS "compileThreadResult: TileReturns unhandled." diff --git a/src/Futhark/CodeGen/ImpGen/Kernels/SegHist.hs b/src/Futhark/CodeGen/ImpGen/Kernels/SegHist.hs --- a/src/Futhark/CodeGen/ImpGen/Kernels/SegHist.hs +++ b/src/Futhark/CodeGen/ImpGen/Kernels/SegHist.hs @@ -48,8 +48,8 @@ import Prelude hiding (quot, rem) import Futhark.MonadFreshNames -import Futhark.Representation.KernelsMem -import qualified Futhark.Representation.Mem.IxFun as IxFun +import Futhark.IR.KernelsMem +import qualified Futhark.IR.Mem.IxFun as IxFun import Futhark.Pass.ExplicitAllocations() import qualified Futhark.CodeGen.ImpCode.Kernels as Imp import Futhark.CodeGen.ImpGen @@ -866,10 +866,7 @@ return (pick_local, run) --- Most of this function is not the histogram part itself, but rather --- figuring out whether to use a local or global memory strategy, as --- well as collapsing the subhistograms produced (which are always in --- global memory, but their number may vary). +-- | Generate code for a segmented histogram called from the host. compileSegHist :: Pattern KernelsMem -> Count NumGroups SubExp -> Count GroupSize SubExp -> SegSpace @@ -877,6 +874,10 @@ -> KernelBody KernelsMem -> CallKernelGen () compileSegHist (Pattern _ pes) num_groups group_size space ops kbody = do + -- Most of this function is not the histogram part itself, but + -- rather figuring out whether to use a local or global memory + -- strategy, as well as collapsing the subhistograms produced (which + -- are always in global memory, but their number may vary). num_groups' <- traverse toExp num_groups group_size' <- traverse toExp group_size diff --git a/src/Futhark/CodeGen/ImpGen/Kernels/SegMap.hs b/src/Futhark/CodeGen/ImpGen/Kernels/SegMap.hs --- a/src/Futhark/CodeGen/ImpGen/Kernels/SegMap.hs +++ b/src/Futhark/CodeGen/ImpGen/Kernels/SegMap.hs @@ -8,7 +8,7 @@ import Prelude hiding (quot, rem) -import Futhark.Representation.KernelsMem +import Futhark.IR.KernelsMem import Futhark.CodeGen.ImpGen.Kernels.Base import Futhark.CodeGen.ImpGen import qualified Futhark.CodeGen.ImpCode.Kernels as Imp diff --git a/src/Futhark/CodeGen/ImpGen/Kernels/SegRed.hs b/src/Futhark/CodeGen/ImpGen/Kernels/SegRed.hs --- a/src/Futhark/CodeGen/ImpGen/Kernels/SegRed.hs +++ b/src/Futhark/CodeGen/ImpGen/Kernels/SegRed.hs @@ -56,11 +56,11 @@ import Futhark.Error import Futhark.Transform.Rename -import Futhark.Representation.KernelsMem +import Futhark.IR.KernelsMem import qualified Futhark.CodeGen.ImpCode.Kernels as Imp import Futhark.CodeGen.ImpGen import Futhark.CodeGen.ImpGen.Kernels.Base -import qualified Futhark.Representation.Mem.IxFun as IxFun +import qualified Futhark.IR.Mem.IxFun as IxFun import Futhark.Util (chunks) import Futhark.Util.IntegralExp (quotRoundingUp, quot, rem) @@ -124,7 +124,7 @@ let red_op_params = lambdaParams red_op (red_acc_params, _) = splitAt (length nes) red_op_params forM red_acc_params $ \p -> - case paramAttr p of + case paramDec p of MemArray pt shape _ (ArrayIn mem _) -> do let shape' = Shape [num_threads] <> shape sArray "red_arr" pt shape' $ diff --git a/src/Futhark/CodeGen/ImpGen/Kernels/SegScan.hs b/src/Futhark/CodeGen/ImpGen/Kernels/SegScan.hs --- a/src/Futhark/CodeGen/ImpGen/Kernels/SegScan.hs +++ b/src/Futhark/CodeGen/ImpGen/Kernels/SegScan.hs @@ -12,11 +12,11 @@ import Prelude hiding (quot, rem) import Futhark.Transform.Rename -import Futhark.Representation.KernelsMem +import Futhark.IR.KernelsMem import qualified Futhark.CodeGen.ImpCode.Kernels as Imp import Futhark.CodeGen.ImpGen import Futhark.CodeGen.ImpGen.Kernels.Base -import qualified Futhark.Representation.Mem.IxFun as IxFun +import qualified Futhark.IR.Mem.IxFun as IxFun import Futhark.Util.IntegralExp (quotRoundingUp, quot, rem) import Futhark.Util (takeLast) @@ -37,7 +37,7 @@ let (scan_x_params, _scan_y_params) = splitAt (length nes) $ lambdaParams scan_op (arrs, used_mems) <- fmap unzip $ forM scan_x_params $ \p -> - case paramAttr p of + case paramDec p of MemArray pt shape _ (ArrayIn mem _) -> do let shape' = Shape [num_threads] <> shape arr <- lift $ sArray "scan_arr" pt shape' $ diff --git a/src/Futhark/CodeGen/ImpGen/Kernels/ToOpenCL.hs b/src/Futhark/CodeGen/ImpGen/Kernels/ToOpenCL.hs --- a/src/Futhark/CodeGen/ImpGen/Kernels/ToOpenCL.hs +++ b/src/Futhark/CodeGen/ImpGen/Kernels/ToOpenCL.hs @@ -22,7 +22,7 @@ import qualified Language.C.Quote.CUDA as CUDAC import qualified Futhark.CodeGen.Backends.GenericC as GenericC -import Futhark.CodeGen.Backends.SimpleRepresentation +import Futhark.CodeGen.Backends.SimpleRep import Futhark.CodeGen.ImpCode.Kernels hiding (Program) import qualified Futhark.CodeGen.ImpCode.Kernels as ImpKernels import Futhark.CodeGen.ImpCode.OpenCL hiding (Program) diff --git a/src/Futhark/CodeGen/ImpGen/Kernels/Transpose.hs b/src/Futhark/CodeGen/ImpGen/Kernels/Transpose.hs --- a/src/Futhark/CodeGen/ImpGen/Kernels/Transpose.hs +++ b/src/Futhark/CodeGen/ImpGen/Kernels/Transpose.hs @@ -1,7 +1,8 @@ +-- | Carefully optimised implementations of GPU transpositions. +-- Written in ImpCode so we can compile it to both CUDA and OpenCL. module Futhark.CodeGen.ImpGen.Kernels.Transpose ( TransposeType(..) , TransposeArgs - , mapTranspose , mapTransposeKernel ) where @@ -9,7 +10,7 @@ import Prelude hiding (quot, rem) import Futhark.CodeGen.ImpCode.Kernels -import Futhark.Representation.AST.Attributes.Types +import Futhark.IR.Prop.Types import Futhark.Util.IntegralExp (IntegralExp, quot, rem, quotRoundingUp) -- | Which form of transposition to generate code for. @@ -20,6 +21,7 @@ -- benefit from coalescing. deriving (Eq, Ord, Show) +-- | The types of the arguments accepted by a transposition function. type TransposeArgs = (VName, Exp, VName, Exp, Exp, Exp, Exp, Exp, @@ -29,33 +31,6 @@ elemsPerThread :: IntegralExp a => a elemsPerThread = 4 --- | Generate a transpose kernel. There is special support to handle --- input arrays with low width, low height, or both. --- --- Normally when transposing a @[2][n]@ array we would use a @FUT_BLOCK_DIM x --- FUT_BLOCK_DIM@ group to process a @[2][FUT_BLOCK_DIM]@ slice of the input --- array. This would mean that many of the threads in a group would be inactive. --- We try to remedy this by using a special kernel that will process a larger --- part of the input, by using more complex indexing. In our example, we could --- use all threads in a group if we are processing @(2/FUT_BLOCK_DIM)@ as large --- a slice of each rows per group. The variable 'mulx' contains this factor for --- the kernel to handle input arrays with low height. --- --- See issue #308 on GitHub for more details. --- --- These kernels are optimized to ensure all global reads and writes --- are coalesced, and to avoid bank conflicts in shared memory. Each --- thread group transposes a 2D tile of block_dim*2 by block_dim*2 --- elements. The size of a thread group is block_dim/2 by --- block_dim*2, meaning that each thread will process 4 elements in a --- 2D tile. The shared memory array containing the 2D tile consists --- of block_dim*2 by block_dim*2+1 elements. Padding each row with --- an additional element prevents bank conflicts from occuring when --- the tile is accessed column-wise. --- --- Note that input_size and output_size may not equal width*height if --- we are dealing with a truncated array - this happens sometimes for --- coalescing optimisations. mapTranspose :: Exp -> TransposeArgs -> PrimType -> TransposeType -> KernelCode mapTranspose block_dim args t kind = case kind of @@ -209,6 +184,33 @@ t (Space "local") Nonvolatile ] +-- | Generate a transpose kernel. There is special support to handle +-- input arrays with low width, low height, or both. +-- +-- Normally when transposing a @[2][n]@ array we would use a @FUT_BLOCK_DIM x +-- FUT_BLOCK_DIM@ group to process a @[2][FUT_BLOCK_DIM]@ slice of the input +-- array. This would mean that many of the threads in a group would be inactive. +-- We try to remedy this by using a special kernel that will process a larger +-- part of the input, by using more complex indexing. In our example, we could +-- use all threads in a group if we are processing @(2/FUT_BLOCK_DIM)@ as large +-- a slice of each rows per group. The variable @mulx@ contains this factor for +-- the kernel to handle input arrays with low height. +-- +-- See issue #308 on GitHub for more details. +-- +-- These kernels are optimized to ensure all global reads and writes +-- are coalesced, and to avoid bank conflicts in shared memory. Each +-- thread group transposes a 2D tile of block_dim*2 by block_dim*2 +-- elements. The size of a thread group is block_dim/2 by +-- block_dim*2, meaning that each thread will process 4 elements in a +-- 2D tile. The shared memory array containing the 2D tile consists +-- of block_dim*2 by block_dim*2+1 elements. Padding each row with +-- an additional element prevents bank conflicts from occuring when +-- the tile is accessed column-wise. +-- +-- Note that input_size and output_size may not equal width*height if +-- we are dealing with a truncated array - this happens sometimes for +-- coalescing optimisations. mapTransposeKernel :: String -> Integer -> TransposeArgs -> PrimType -> TransposeType -> Kernel mapTransposeKernel desc block_dim_int args t kind = diff --git a/src/Futhark/CodeGen/ImpGen/OpenCL.hs b/src/Futhark/CodeGen/ImpGen/OpenCL.hs --- a/src/Futhark/CodeGen/ImpGen/OpenCL.hs +++ b/src/Futhark/CodeGen/ImpGen/OpenCL.hs @@ -2,7 +2,7 @@ ( compileProg ) where -import Futhark.Representation.KernelsMem +import Futhark.IR.KernelsMem import qualified Futhark.CodeGen.ImpCode.OpenCL as OpenCL import qualified Futhark.CodeGen.ImpGen.Kernels as ImpGenKernels import Futhark.CodeGen.ImpGen.Kernels.ToOpenCL diff --git a/src/Futhark/CodeGen/ImpGen/Sequential.hs b/src/Futhark/CodeGen/ImpGen/Sequential.hs --- a/src/Futhark/CodeGen/ImpGen/Sequential.hs +++ b/src/Futhark/CodeGen/ImpGen/Sequential.hs @@ -1,5 +1,6 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} +-- | Compile Futhark to sequential imperative code. module Futhark.CodeGen.ImpGen.Sequential ( compileProg ) @@ -7,9 +8,10 @@ import qualified Futhark.CodeGen.ImpCode.Sequential as Imp import qualified Futhark.CodeGen.ImpGen as ImpGen -import Futhark.Representation.SeqMem +import Futhark.IR.SeqMem import Futhark.MonadFreshNames +-- | Compile a 'SeqMem' program to sequential imperative code. compileProg :: MonadFreshNames m => Prog SeqMem -> m Imp.Program compileProg = ImpGen.compileProg () ops Imp.DefaultSpace where ops = ImpGen.defaultOperations opCompiler diff --git a/src/Futhark/CodeGen/OpenCL/Heuristics.hs b/src/Futhark/CodeGen/OpenCL/Heuristics.hs --- a/src/Futhark/CodeGen/OpenCL/Heuristics.hs +++ b/src/Futhark/CodeGen/OpenCL/Heuristics.hs @@ -1,3 +1,14 @@ +-- | Some OpenCL platforms have a SIMD/warp/wavefront-based execution +-- model that execute groups of threads in lockstep, permitting us to +-- perform cross-thread synchronisation within each such group without +-- the use of barriers. Unfortunately, there seems to be no reliable +-- way to query these sizes at runtime. Instead, we use builtin +-- tables to figure out which size we should use for a specific +-- platform and device. If nothing matches here, the wave size should +-- be set to one. +-- +-- We also use this to select reasonable default group sizes and group +-- counts. module Futhark.CodeGen.OpenCL.Heuristics ( SizeHeuristic (..) , DeviceType (..) @@ -6,18 +17,6 @@ , sizeHeuristicsTable ) where - --- Some OpenCL platforms have a SIMD/warp/wavefront-based execution --- model that execute groups of threads in lockstep, permitting us to --- perform cross-thread synchronisation within each such group without --- the use of barriers. Unfortunately, there seems to be no reliable --- way to query these sizes at runtime. Instead, we use this table to --- figure out which size we should use for a specific platform and --- device. If nothing matches here, the wave size should be set to --- one. --- --- We also use this to select reasonable default group sizes and group --- counts. -- | The type of OpenCL device that this heuristic applies to. data DeviceType = DeviceCPU | DeviceGPU diff --git a/src/Futhark/CodeGen/SetDefaultSpace.hs b/src/Futhark/CodeGen/SetDefaultSpace.hs --- a/src/Futhark/CodeGen/SetDefaultSpace.hs +++ b/src/Futhark/CodeGen/SetDefaultSpace.hs @@ -1,3 +1,7 @@ +-- | Change 'DefaultSpace' in a program to some other memory space. +-- This is needed because the GPU backends use 'DefaultSpace' to refer +-- to GPU memory for most of the pipeline, but final code generation +-- assumes that 'DefaultSpace' is CPU memory. module Futhark.CodeGen.SetDefaultSpace ( setDefaultSpace ) diff --git a/src/Futhark/Compiler.hs b/src/Futhark/Compiler.hs --- a/src/Futhark/Compiler.hs +++ b/src/Futhark/Compiler.hs @@ -1,7 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Safe #-} {-# LANGUAGE Strict #-} -{-# LANGUAGE StrictData #-} +-- | High-level API for invoking the Futhark compiler. module Futhark.Compiler ( runPipelineOnProgram @@ -29,12 +30,12 @@ import Futhark.Internalise import Futhark.Pipeline import Futhark.MonadFreshNames -import Futhark.Representation.AST -import qualified Futhark.Representation.SOACS as I +import Futhark.IR +import qualified Futhark.IR.SOACS as I import qualified Futhark.TypeCheck as I import Futhark.Compiler.Program import Futhark.Util.Log -import Futhark.Util.Pretty (prettyText) +import Futhark.Util.Pretty (prettyText, ppr) -- | The compiler configuration. This only contains options related -- to core compiler functionality, such as reading the initial program @@ -125,7 +126,7 @@ when (pipelineVerbose pipeline_config) $ logMsg ("Type-checking internalised program" :: String) typeCheckInternalProgram int_prog - runPasses pipeline pipeline_config int_prog + runPipeline pipeline pipeline_config int_prog where pipeline_config = PipelineConfig { pipelineVerbose = fst (futharkVerbose config) > NotVerbose , pipelineValidate = True @@ -134,7 +135,7 @@ typeCheckInternalProgram :: I.Prog I.SOACS -> FutharkM () typeCheckInternalProgram prog = case I.checkProg prog' of - Left err -> internalErrorS ("After internalisation:\n" ++ show err) (Just prog') + Left err -> internalErrorS ("After internalisation:\n" ++ show err) (ppr prog') Right () -> return () where prog' = Alias.aliasAnalysis prog diff --git a/src/Futhark/Compiler/CLI.hs b/src/Futhark/Compiler/CLI.hs --- a/src/Futhark/Compiler/CLI.hs +++ b/src/Futhark/Compiler/CLI.hs @@ -17,8 +17,8 @@ import Futhark.Pipeline import Futhark.Compiler -import Futhark.Representation.AST (Prog) -import Futhark.Representation.SOACS (SOACS) +import Futhark.IR (Prog) +import Futhark.IR.SOACS (SOACS) import Futhark.Util.Options -- | Run a parameterised Futhark compiler, where @cfg@ is a user-given diff --git a/src/Futhark/Compiler/Program.hs b/src/Futhark/Compiler/Program.hs --- a/src/Futhark/Compiler/Program.hs +++ b/src/Futhark/Compiler/Program.hs @@ -15,7 +15,6 @@ ) where -import Data.Loc import Control.Exception import Control.Monad import Control.Monad.Reader @@ -130,7 +129,7 @@ where prelude_str = "/" Posix. includeToString include Posix.<.> "fut" not_found = - "Error at " ++ E.locStr (srclocOf include) ++ + "Error at " ++ E.locStr (E.srclocOf include) ++ ": could not find import '" ++ includeToString include ++ "'." -- | Read Futhark files from some basis, and printing log messages if @@ -190,4 +189,4 @@ where mkImport fp = -- We do not use ImportDec here, because we do not want the -- type checker to issue a warning about a redundant import. - E.LocalDec (E.OpenDec (E.ModImport fp E.NoInfo noLoc) noLoc) noLoc + E.LocalDec (E.OpenDec (E.ModImport fp E.NoInfo mempty) mempty) mempty diff --git a/src/Futhark/Construct.hs b/src/Futhark/Construct.hs --- a/src/Futhark/Construct.hs +++ b/src/Futhark/Construct.hs @@ -1,6 +1,56 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE Safe #-} +-- | = Constructing Futhark ASTs +-- +-- This module re-exports and defines a bunch of building blocks for +-- constructing fragments of Futhark ASTs. More importantly, it also +-- contains a basic introduction on how to use them. +-- +-- The "Futhark.IR.Syntax" module contains the core +-- AST definition. One important invariant is that all bound names in +-- a Futhark program must be /globally/ unique. In principle, you +-- could use the facilities from "Futhark.MonadFreshNames" (or your +-- own bespoke source of unique names) to manually construct +-- expressions, statements, and entire ASTs. In practice, this would +-- be very tedious. Instead, we have defined a collection of building +-- blocks (centered around the 'MonadBinder' type class) that permits +-- a more abstract way of generating code. +-- +-- Constructing ASTs with these building blocks requires you to ensure +-- that all free variables are in scope. See +-- "Futhark.IR.Prop.Scope". +-- +-- == 'MonadBinder' +-- +-- A monad that implements 'MonadBinder' tracks the statements added +-- so far, the current names in scope, and allows you to add +-- additional statements with 'addStm'. Any monad that implements +-- 'MonadBinder' also implements the t'Lore' type family, which +-- indicates which lore it works with. Inside a 'MonadBinder' we can +-- use 'collectStms' to gather up the 'Stms' added with 'addStm' in +-- some nested computation. +-- +-- The 'BinderT' monad (and its convenient 'Binder' version) provides +-- the simplest implementation of 'MonadBinder'. +-- +-- == Higher-level building blocks +-- +-- On top of the raw facilities provided by 'MonadBinder', we have +-- more convenient facilities. For example, 'letSubExp' lets us +-- conveniently create a 'Stm' for an 'Exp' that produces a /single/ +-- value, and returns the (fresh) name for the resulting variable: +-- +-- @ +-- z <- letExp "z" $ BasicOp $ BinOp (Add Int32) (Var x) (Var y) +-- @ +-- +-- == Examples +-- +-- The "Futhark.Transform.FirstOrderTransform" module is a +-- (relatively) simple example of how to use these components. As are +-- some of the high-level building blocks in this very module. module Futhark.Construct ( letSubExp , letSubExps @@ -58,17 +108,17 @@ , simpleMkLetNames , ToExp(..) + , toSubExp ) where import qualified Data.Map.Strict as M -import Data.Loc (SrcLoc) import Data.List (sortOn) import Control.Monad.Identity import Control.Monad.State import Control.Monad.Writer -import Futhark.Representation.AST +import Futhark.IR import Futhark.MonadFreshNames import Futhark.Binder @@ -84,10 +134,10 @@ letExp desc e = do n <- length <$> expExtType e vs <- replicateM n $ newVName desc - idents <- letBindNames vs e - case idents of - [ident] -> return $ identName ident - _ -> error $ "letExp: tuple-typed expression given:\n" ++ pretty e + letBindNames vs e + case vs of + [v] -> return v + _ -> error $ "letExp: tuple-typed expression given:\n" ++ pretty e letInPlace :: MonadBinder m => String -> VName -> Slice SubExp -> Exp (Lore m) @@ -108,7 +158,8 @@ letTupExp name e = do numValues <- length <$> expExtType e names <- replicateM numValues $ newVName name - map identName <$> letBindNames names e + letBindNames names e + return names letTupExp' :: (MonadBinder m) => String -> Exp (Lore m) @@ -138,7 +189,7 @@ ts <- generaliseExtTypes <$> bodyExtType te' <*> bodyExtType fe' te'' <- addContextForBranch ts te' fe'' <- addContextForBranch ts fe' - return $ If ce' te'' fe'' $ IfAttr ts if_sort + return $ If ce' te'' fe'' $ IfDec ts if_sort where addContextForBranch ts (Body _ stms val_res) = do body_ts <- extendedScope (traverse subExpType val_res) stmsscope let ctx_res = map snd $ sortOn fst $ @@ -146,6 +197,14 @@ mkBodyM stms $ ctx_res++val_res where stmsscope = scopeOf stms +-- The type of a body. Watch out: this only works for the degenerate +-- case where the body does not already return its context. +bodyExtType :: (HasScope lore m, Monad m) => Body lore -> m [ExtType] +bodyExtType (Body _ stms res) = + existentialiseExtTypes (M.keys stmsscope) . staticShapes <$> + extendedScope (traverse subExpType res) stmsscope + where stmsscope = scopeOf stms + eBinOp :: MonadBinder m => BinOp -> m (Exp (Lore m)) -> m (Exp (Lore m)) -> m (Exp (Lore m)) @@ -206,7 +265,7 @@ Lambda (Lore m) -> [m (Exp (Lore m))] -> m [SubExp] eLambda lam args = do zipWithM_ bindParam (lambdaParams lam) args bodyBind $ lambdaBody lam - where bindParam param arg = letBindNames_ [paramName param] =<< arg + where bindParam param arg = letBindNames [paramName param] =<< arg -- | Note: unsigned division. eDivRoundingUp :: MonadBinder m => @@ -322,7 +381,7 @@ BinOp -> PrimType -> m (Lambda (Lore m)) binOpLambda bop t = binLambda (BinOp bop) t t --- | As 'binOpLambda', but for 'CmpOp's. +-- | As 'binOpLambda', but for t'CmpOp's. cmpOpLambda :: (MonadBinder m, Bindable (Lore m)) => CmpOp -> PrimType -> m (Lambda (Lore m)) cmpOpLambda cop t = binLambda (CmpOp cop) t Bool @@ -376,8 +435,8 @@ allOfIt d (DimSlice _ n _) = d == n allOfIt _ _ = False -ifCommon :: [Type] -> IfAttr ExtType -ifCommon ts = IfAttr (staticShapes ts) IfNormal +ifCommon :: [Type] -> IfDec ExtType +ifCommon ts = IfDec (staticShapes ts) IfNormal -- | Conveniently construct a body that contains no bindings. resultBody :: Bindable lore => [SubExp] -> Body lore @@ -407,7 +466,7 @@ in mkBody (bnds<>bnds2) newres -- | Instantiate all existential parts dimensions of the given --- type, using a monadic action to create the necessary 'SubExp's. +-- type, using a monadic action to create the necessary t'SubExp's. -- You should call this function within some monad that allows you to -- collect the actions performed (say, 'Writer'). instantiateShapes :: Monad m => @@ -447,7 +506,7 @@ -- | Can be used as the definition of 'mkLetNames' for a 'Bindable' -- instance for simple representations. -simpleMkLetNames :: (ExpAttr lore ~ (), LetAttr lore ~ Type, +simpleMkLetNames :: (ExpDec lore ~ (), LetDec lore ~ Type, MonadFreshNames m, TypedOp (Op lore), HasScope lore m) => [VName] -> Exp lore -> m (Stm lore) simpleMkLetNames names e = do @@ -455,7 +514,7 @@ (ts, shapes) <- instantiateShapes' et let shapeElems = [ PatElem shape shapet | Ident shape shapet <- shapes ] let valElems = zipWith PatElem names ts - return $ Let (Pattern shapeElems valElems) (StmAux mempty ()) e + return $ Let (Pattern shapeElems valElems) (defAux ()) e -- | Instances of this class can be converted to Futhark expressions -- within a 'MonadBinder'. @@ -467,3 +526,7 @@ instance ToExp VName where toExp = return . BasicOp . SubExp . Var + +-- | A convenient composition of 'letSubExp' and 'toExp'. +toSubExp :: (MonadBinder m, ToExp a) => String -> a -> m SubExp +toSubExp s e = letSubExp s =<< toExp e diff --git a/src/Futhark/Doc/Generator.hs b/src/Futhark/Doc/Generator.hs --- a/src/Futhark/Doc/Generator.hs +++ b/src/Futhark/Doc/Generator.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +-- | The core logic of @futhark doc@. module Futhark.Doc.Generator (renderFiles) where import Control.Arrow ((***)) @@ -7,7 +8,6 @@ import Control.Monad.Writer hiding (Sum) import Data.List (sort, sortOn, intersperse, inits, tails, isPrefixOf, find, groupBy, partition) import Data.Char (isSpace, isAlpha, toUpper) -import Data.Loc import Data.Maybe import Data.Ord import qualified Data.Map as M @@ -26,9 +26,40 @@ import Language.Futhark.Semantic import Language.Futhark.TypeChecker.Monad hiding (warn) import Language.Futhark -import Futhark.Doc.Html +import Futhark.Util.Pretty (Doc, ppr) import Futhark.Version +docToHtml :: Doc -> Html +docToHtml = toHtml . pretty + +primTypeHtml :: PrimType -> Html +primTypeHtml = docToHtml . ppr + +prettyU :: Uniqueness -> Html +prettyU = docToHtml . ppr + +renderName :: Name -> Html +renderName name = docToHtml (ppr name) + +joinBy :: Html -> [Html] -> Html +joinBy _ [] = mempty +joinBy _ [x] = x +joinBy sep (x:xs) = x <> foldMap (sep <>) xs + +commas :: [Html] -> Html +commas = joinBy ", " + +parens :: Html -> Html +parens x = "(" <> x <> ")" + +braces :: Html -> Html +braces x = "{" <> x <> "}" +brackets :: Html -> Html +brackets x = "[" <> x <> "]" + +pipes :: [Html] -> Html +pipes = joinBy " | " + -- | A set of names that we should not generate links to, because they -- are uninteresting. These are for example type parameters. type NoLink = S.Set VName @@ -91,6 +122,11 @@ forMod ModFun{} = mempty forMty = forMod . mtyMod +-- | @renderFiles important_imports imports@ produces HTML files +-- documenting the type-checked program @imports@, with the files in +-- @important_imports@ considered most important. The HTML files must +-- be written to the specific locations indicated in the return value, +-- or the relative links will be wrong. renderFiles :: [FilePath] -> Imports -> ([(FilePath, Html)], Warnings) renderFiles important_imports imports = runWriter $ do (import_pages, documented) <- runWriterT $ forM imports $ \(current, fm) -> @@ -540,7 +576,7 @@ vnameLink :: VName -> DocM String vnameLink vname = do current <- asks ctxCurrent - file <- maybe current fst <$> asks (M.lookup vname . ctxFileMap) + file <- asks $ maybe current fst . M.lookup vname . ctxFileMap return $ vnameLink' vname current file vnameLink' (VName _ tag) current file = @@ -623,7 +659,7 @@ lookupName :: (Namespace, String, Maybe FilePath) -> DocM (Maybe VName) lookupName (namespace, name, file) = do current <- asks ctxCurrent - let file' = includeToString . flip (mkImportFrom (mkInitialImport current)) noLoc <$> file + let file' = includeToString . flip (mkImportFrom (mkInitialImport current)) mempty <$> file env <- lookupEnvForFile file' case M.lookup (namespace, nameFromString name) . envNameMap =<< env of Nothing -> return Nothing diff --git a/src/Futhark/Doc/Html.hs b/src/Futhark/Doc/Html.hs deleted file mode 100644 --- a/src/Futhark/Doc/Html.hs +++ /dev/null @@ -1,49 +0,0 @@ -module Futhark.Doc.Html - ( primTypeHtml - , prettyU - , renderName - , joinBy - , commas - , brackets - , braces - , parens - , pipes - ) -where - -import Language.Futhark -import Futhark.Util.Pretty (Doc,ppr) - -import qualified Text.PrettyPrint.Mainland as PP (pretty) -import Text.Blaze.Html5 (toHtml, Html) - -docToHtml :: Doc -> Html -docToHtml = toHtml . PP.pretty 80 - -primTypeHtml :: PrimType -> Html -primTypeHtml = docToHtml . ppr - -prettyU :: Uniqueness -> Html -prettyU = docToHtml . ppr - -renderName :: Name -> Html -renderName name = docToHtml (ppr name) - -joinBy :: Html -> [Html] -> Html -joinBy _ [] = mempty -joinBy _ [x] = x -joinBy sep (x:xs) = x <> foldMap (sep <>) xs - -commas :: [Html] -> Html -commas = joinBy (toHtml ", ") - -parens :: Html -> Html -parens x = toHtml "(" <> x <> toHtml ")" - -braces :: Html -> Html -braces x = toHtml "{" <> x <> toHtml "}" -brackets :: Html -> Html -brackets x = toHtml "[" <> x <> toHtml "]" - -pipes :: [Html] -> Html -pipes = joinBy (toHtml " | ") diff --git a/src/Futhark/Error.hs b/src/Futhark/Error.hs --- a/src/Futhark/Error.hs +++ b/src/Futhark/Error.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Safe #-} -- | Futhark error definitions. module Futhark.Error ( CompilerError(..) @@ -12,6 +13,7 @@ , compilerBugS , compilerLimitation , compilerLimitationS + , internalErrorS ) where @@ -27,6 +29,7 @@ | CompilerLimitation deriving (Eq, Ord, Show) +-- | A compiler error. data CompilerError = ExternalError Doc -- ^ An error that happened due to something the user did, such as @@ -39,12 +42,19 @@ show (ExternalError s) = pretty s show (InternalError s _ _) = T.unpack s +-- | Raise an 'ExternalError' based on a prettyprinting result. externalError :: MonadError CompilerError m => Doc -> m a externalError = throwError . ExternalError +-- | Raise an 'ExternalError' based on a string. externalErrorS :: MonadError CompilerError m => String -> m a externalErrorS = externalError . text +-- | Raise an v'InternalError' based on a prettyprinting result. +internalErrorS :: MonadError CompilerError m => String -> Doc -> m a +internalErrorS s d = + throwError $ InternalError (T.pack s) (prettyText d) CompilerBug + -- | An error that is not the users fault, but a bug (or limitation) -- in the compiler. Compiler passes should only ever report this -- error - any problems after the type checker are *our* fault, not @@ -55,14 +65,18 @@ instance Exception InternalError +-- | Throw an t'InternalError' that is a 'CompilerBug'. compilerBug :: T.Text -> a compilerBug = throw . Error CompilerBug +-- | Throw an t'InternalError' that is a 'CompilerLimitation'. compilerLimitation :: T.Text -> a compilerLimitation = throw . Error CompilerLimitation +-- | Like 'compilerBug', but with a 'String'. compilerBugS :: String -> a compilerBugS = compilerBug . T.pack +-- | Like 'compilerLimitation', but with a 'String'. compilerLimitationS :: String -> a compilerLimitationS = compilerLimitation . T.pack diff --git a/src/Futhark/IR.hs b/src/Futhark/IR.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/IR.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE Safe #-} +-- | A convenient re-export of basic AST modules. Note that +-- "Futhark.IR.Lore" is not exported, as this would +-- cause name clashes. You are advised to use a qualified import of +-- the lore module, if you need it. +module Futhark.IR + ( module Futhark.IR.Prop + , module Futhark.IR.Traversals + , module Futhark.IR.Pretty + , module Futhark.IR.Syntax + ) +where + +import Futhark.IR.Syntax +import Futhark.IR.Prop +import Futhark.IR.Traversals +import Futhark.IR.Pretty diff --git a/src/Futhark/IR/Aliases.hs b/src/Futhark/IR/Aliases.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/IR/Aliases.hs @@ -0,0 +1,359 @@ +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +-- | A representation where all bindings are annotated with aliasing +-- information. +module Futhark.IR.Aliases + ( -- * The Lore definition + Aliases + , Names' (..) + , VarAliases + , ConsumedInExp + , BodyAliasing + , module Futhark.IR.Prop.Aliases + -- * Module re-exports + , module Futhark.IR.Prop + , module Futhark.IR.Traversals + , module Futhark.IR.Pretty + , module Futhark.IR.Syntax + -- * Adding aliases + , addAliasesToPattern + , mkAliasedLetStm + , mkAliasedBody + , mkPatternAliases + , mkBodyAliases + -- * Removing aliases + , removeProgAliases + , removeFunDefAliases + , removeExpAliases + , removeStmAliases + , removeLambdaAliases + , removePatternAliases + , removeScopeAliases + -- * Tracking aliases + , AliasesAndConsumed + , trackAliases + , consumedInStms + ) +where + +import Control.Monad.Identity +import Control.Monad.Reader +import Data.Maybe +import qualified Data.Map.Strict as M + +import Futhark.IR.Syntax +import Futhark.IR.Prop +import Futhark.IR.Prop.Aliases +import Futhark.IR.Traversals +import Futhark.IR.Pretty +import Futhark.Transform.Rename +import Futhark.Binder +import Futhark.Transform.Substitute +import Futhark.Analysis.Rephrase +import qualified Futhark.Util.Pretty as PP + +-- | The lore for the basic representation. +data Aliases lore + +-- | A wrapper around 'Names' to get around the fact that we need an +-- 'Ord' instance, which 'Names' does not have. +newtype Names' = Names' { unNames :: Names } + deriving (Show) + +instance Semigroup Names' where + x <> y = Names' $ unNames x <> unNames y + +instance Monoid Names' where + mempty = Names' mempty + +instance Eq Names' where + _ == _ = True + +instance Ord Names' where + _ `compare` _ = EQ + +instance Rename Names' where + rename (Names' names) = Names' <$> rename names + +instance Substitute Names' where + substituteNames substs (Names' names) = Names' $ substituteNames substs names + +instance FreeIn Names' where + freeIn' = const mempty + +instance PP.Pretty Names' where + ppr = PP.commasep . map PP.ppr . namesToList . unNames + +-- | The aliases of the let-bound variable. +type VarAliases = Names' + +-- | Everything consumed in the expression. +type ConsumedInExp = Names' + +-- | The aliases of what is returned by the t'Body', and what is +-- consumed inside of it. +type BodyAliasing = ([VarAliases], ConsumedInExp) + +instance (Decorations lore, CanBeAliased (Op lore)) => + Decorations (Aliases lore) where + type LetDec (Aliases lore) = (VarAliases, LetDec lore) + type ExpDec (Aliases lore) = (ConsumedInExp, ExpDec lore) + type BodyDec (Aliases lore) = (BodyAliasing, BodyDec lore) + type FParamInfo (Aliases lore) = FParamInfo lore + type LParamInfo (Aliases lore) = LParamInfo lore + type RetType (Aliases lore) = RetType lore + type BranchType (Aliases lore) = BranchType lore + type Op (Aliases lore) = OpWithAliases (Op lore) + +instance AliasesOf (VarAliases, dec) where + aliasesOf = unNames . fst + +instance FreeDec Names' where + +withoutAliases :: (HasScope (Aliases lore) m, Monad m) => + ReaderT (Scope lore) m a -> m a +withoutAliases m = do + scope <- asksScope removeScopeAliases + runReaderT m scope + +instance (ASTLore lore, CanBeAliased (Op lore)) => ASTLore (Aliases lore) where + expTypesFromPattern = + withoutAliases . expTypesFromPattern . removePatternAliases + +instance (ASTLore lore, CanBeAliased (Op lore)) => Aliased (Aliases lore) where + bodyAliases = map unNames . fst . fst . bodyDec + consumedInBody = unNames . snd . fst . bodyDec + +instance PrettyAnnot (PatElemT dec) => + PrettyAnnot (PatElemT (VarAliases, dec)) where + + ppAnnot (PatElem name (Names' als, dec)) = + let alias_comment = PP.oneLine <$> aliasComment name als + in case (alias_comment, ppAnnot (PatElem name dec)) of + (_, Nothing) -> + alias_comment + (Just alias_comment', Just inner_comment) -> + Just $ alias_comment' PP. inner_comment + (Nothing, Just inner_comment) -> + Just inner_comment + + +instance (ASTLore lore, CanBeAliased (Op lore)) => PrettyLore (Aliases lore) where + ppExpLore (consumed, inner) e = + maybeComment $ catMaybes [exp_dec, + merge_dec, + ppExpLore inner $ removeExpAliases e] + where merge_dec = + case e of + DoLoop _ merge _ body -> + let mergeParamAliases fparam als + | primType (paramType fparam) = + Nothing + | otherwise = + resultAliasComment (paramName fparam) als + in maybeComment $ catMaybes $ + zipWith mergeParamAliases (map fst merge) $ + bodyAliases body + _ -> Nothing + + exp_dec = case namesToList $ unNames consumed of + [] -> Nothing + als -> Just $ PP.oneLine $ + PP.text "-- Consumes " <> PP.commasep (map PP.ppr als) + +maybeComment :: [PP.Doc] -> Maybe PP.Doc +maybeComment [] = Nothing +maybeComment cs = Just $ PP.folddoc (PP.) cs + +aliasComment :: PP.Pretty a => a -> Names -> Maybe PP.Doc +aliasComment name als = + case namesToList als of + [] -> Nothing + als' -> Just $ PP.oneLine $ + PP.text "-- " <> PP.ppr name <> PP.text " aliases " <> + PP.commasep (map PP.ppr als') + +resultAliasComment :: PP.Pretty a => a -> Names -> Maybe PP.Doc +resultAliasComment name als = + case namesToList als of + [] -> Nothing + als' -> Just $ PP.oneLine $ + PP.text "-- Result of " <> PP.ppr name <> PP.text " aliases " <> + PP.commasep (map PP.ppr als') + +removeAliases :: CanBeAliased (Op lore) => Rephraser Identity (Aliases lore) lore +removeAliases = Rephraser { rephraseExpLore = return . snd + , rephraseLetBoundLore = return . snd + , rephraseBodyLore = return . snd + , rephraseFParamLore = return + , rephraseLParamLore = return + , rephraseRetType = return + , rephraseBranchType = return + , rephraseOp = return . removeOpAliases + } + +removeScopeAliases :: Scope (Aliases lore) -> Scope lore +removeScopeAliases = M.map unAlias + where unAlias (LetName (_, dec)) = LetName dec + unAlias (FParamName dec) = FParamName dec + unAlias (LParamName dec) = LParamName dec + unAlias (IndexName it) = IndexName it + +removeProgAliases :: CanBeAliased (Op lore) => + Prog (Aliases lore) -> Prog lore +removeProgAliases = runIdentity . rephraseProg removeAliases + +removeFunDefAliases :: CanBeAliased (Op lore) => + FunDef (Aliases lore) -> FunDef lore +removeFunDefAliases = runIdentity . rephraseFunDef removeAliases + +removeExpAliases :: CanBeAliased (Op lore) => + Exp (Aliases lore) -> Exp lore +removeExpAliases = runIdentity . rephraseExp removeAliases + +removeStmAliases :: CanBeAliased (Op lore) => + Stm (Aliases lore) -> Stm lore +removeStmAliases = runIdentity . rephraseStm removeAliases + +removeLambdaAliases :: CanBeAliased (Op lore) => + Lambda (Aliases lore) -> Lambda lore +removeLambdaAliases = runIdentity . rephraseLambda removeAliases + +removePatternAliases :: PatternT (Names', a) + -> PatternT a +removePatternAliases = runIdentity . rephrasePattern (return . snd) + +addAliasesToPattern :: (ASTLore lore, CanBeAliased (Op lore), Typed dec) => + PatternT dec -> Exp (Aliases lore) + -> PatternT (VarAliases, dec) +addAliasesToPattern pat e = + uncurry Pattern $ mkPatternAliases pat e + +mkAliasedBody :: (ASTLore lore, CanBeAliased (Op lore)) => + BodyDec lore -> Stms (Aliases lore) -> Result -> Body (Aliases lore) +mkAliasedBody innerlore bnds res = + Body (mkBodyAliases bnds res, innerlore) bnds res + +mkPatternAliases :: (Aliased lore, Typed dec) => + PatternT dec -> Exp lore + -> ([PatElemT (VarAliases, dec)], + [PatElemT (VarAliases, dec)]) +mkPatternAliases pat e = + -- Some part of the pattern may be the context. This does not have + -- aliases from expAliases, so we use a hack to compute aliases of + -- the context. + let als = expAliases e ++ repeat mempty -- In case the pattern has + -- more elements (this + -- implies a type error). + context_als = mkContextAliases pat e + in (zipWith annotateBindee (patternContextElements pat) context_als, + zipWith annotateBindee (patternValueElements pat) als) + where annotateBindee bindee names = + bindee `setPatElemLore` (Names' names', patElemDec bindee) + where names' = + case patElemType bindee of + Array {} -> names + Mem _ -> names + _ -> mempty + +mkContextAliases :: Aliased lore => + PatternT dec -> Exp lore -> [Names] +mkContextAliases pat (DoLoop ctxmerge valmerge _ body) = + let ctx = map fst ctxmerge + init_als = zip mergenames $ map (subExpAliases . snd) $ ctxmerge ++ valmerge + expand als = als <> mconcat (mapMaybe (`lookup` init_als) (namesToList als)) + merge_als = zip mergenames $ + map ((`namesSubtract` mergenames_set) . expand) $ + bodyAliases body + in if length ctx == length (patternContextElements pat) + then map (fromMaybe mempty . flip lookup merge_als . paramName) ctx + else map (const mempty) $ patternContextElements pat + where mergenames = map (paramName . fst) $ ctxmerge ++ valmerge + mergenames_set = namesFromList mergenames +mkContextAliases pat (If _ tbranch fbranch _) = + take (length $ patternContextNames pat) $ + zipWith (<>) (bodyAliases tbranch) (bodyAliases fbranch) +mkContextAliases pat _ = + replicate (length $ patternContextElements pat) mempty + +mkBodyAliases :: Aliased lore => + Stms lore + -> Result + -> BodyAliasing +mkBodyAliases bnds res = + -- We need to remove the names that are bound in bnds from the alias + -- and consumption sets. We do this by computing the transitive + -- closure of the alias map (within bnds), then removing anything + -- bound in bnds. + let (aliases, consumed) = mkStmsAliases bnds res + boundNames = + foldMap (namesFromList . patternNames . stmPattern) bnds + aliases' = map (`namesSubtract` boundNames) aliases + consumed' = consumed `namesSubtract` boundNames + in (map Names' aliases', Names' consumed') + +mkStmsAliases :: Aliased lore => + Stms lore -> [SubExp] + -> ([Names], Names) +mkStmsAliases bnds res = delve mempty $ stmsToList bnds + where delve (aliasmap, consumed) [] = + (map (aliasClosure aliasmap . subExpAliases) res, + consumed) + delve (aliasmap, consumed) (bnd:bnds') = + delve (trackAliases (aliasmap, consumed) bnd) bnds' + aliasClosure aliasmap names = + names <> mconcat (map look $ namesToList names) + where look k = M.findWithDefault mempty k aliasmap + +-- | Everything consumed in the given statements and result (even +-- transitively). +consumedInStms :: Aliased lore => Stms lore -> Names +consumedInStms = snd . flip mkStmsAliases [] + +type AliasesAndConsumed = (M.Map VName Names, + Names) + +trackAliases :: Aliased lore => + AliasesAndConsumed -> Stm lore + -> AliasesAndConsumed +trackAliases (aliasmap, consumed) bnd = + let pat = stmPattern bnd + als = M.fromList $ + zip (patternNames pat) (map addAliasesOfAliases $ patternAliases pat) + aliasmap' = als <> aliasmap + consumed' = consumed <> addAliasesOfAliases (consumedInStm bnd) + in (aliasmap', consumed') + where addAliasesOfAliases names = names <> aliasesOfAliases names + aliasesOfAliases = mconcat . map look . namesToList + look k = M.findWithDefault mempty k aliasmap + +mkAliasedLetStm :: (ASTLore lore, CanBeAliased (Op lore)) => + Pattern lore + -> StmAux (ExpDec lore) -> Exp (Aliases lore) + -> Stm (Aliases lore) +mkAliasedLetStm pat (StmAux cs attrs dec) e = + Let (addAliasesToPattern pat e) + (StmAux cs attrs (Names' $ consumedInExp e, dec)) + e + +instance (Bindable lore, CanBeAliased (Op lore)) => Bindable (Aliases lore) where + mkExpDec pat e = + let dec = mkExpDec (removePatternAliases pat) $ removeExpAliases e + in (Names' $ consumedInExp e, dec) + + mkExpPat ctx val e = + addAliasesToPattern (mkExpPat ctx val $ removeExpAliases e) e + + mkLetNames names e = do + env <- asksScope removeScopeAliases + flip runReaderT env $ do + Let pat dec _ <- mkLetNames names $ removeExpAliases e + return $ mkAliasedLetStm pat dec e + + mkBody bnds res = + let Body bodylore _ _ = mkBody (fmap removeStmAliases bnds) res + in mkAliasedBody bodylore bnds res + +instance (ASTLore (Aliases lore), Bindable (Aliases lore)) => BinderOps (Aliases lore) where diff --git a/src/Futhark/IR/Decorations.hs b/src/Futhark/IR/Decorations.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/IR/Decorations.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE TypeFamilies, FlexibleContexts #-} +-- | The core Futhark AST is parameterised by a @lore@ type parameter, +-- which is then used to invoke the type families defined here. +module Futhark.IR.Decorations + ( Decorations (..) + , module Futhark.IR.RetType + ) + where + +import qualified Data.Kind + +import Futhark.IR.Syntax.Core +import Futhark.IR.RetType +import Futhark.IR.Prop.Types + +-- | A collection of type families, along with constraints specifying +-- that the types they map to should satisfy some minimal +-- requirements. +class (Show (LetDec l), Show (ExpDec l), Show (BodyDec l), Show (FParamInfo l), Show (LParamInfo l), Show (RetType l), Show (BranchType l), Show (Op l), + Eq (LetDec l), Eq (ExpDec l), Eq (BodyDec l), Eq (FParamInfo l), Eq (LParamInfo l), Eq (RetType l), Eq (BranchType l), Eq (Op l), + Ord (LetDec l), Ord (ExpDec l), Ord (BodyDec l), Ord (FParamInfo l), Ord (LParamInfo l), Ord (RetType l), Ord (BranchType l), Ord (Op l), + IsRetType (RetType l), IsBodyType (BranchType l), + Typed (FParamInfo l), Typed (LParamInfo l), Typed (LetDec l), + DeclTyped (FParamInfo l)) + => Decorations l where + -- | Decoration for every let-pattern element. + type LetDec l :: Data.Kind.Type + type LetDec l = Type + -- | Decoration for every expression. + type ExpDec l :: Data.Kind.Type + type ExpDec l = () + -- | Decoration for every body. + type BodyDec l :: Data.Kind.Type + type BodyDec l = () + -- | Decoration for every (non-lambda) function parameter. + type FParamInfo l :: Data.Kind.Type + type FParamInfo l = DeclType + -- | Decoration for every lambda function parameter. + type LParamInfo l :: Data.Kind.Type + type LParamInfo l = Type + + -- | The return type decoration of function calls. + type RetType l :: Data.Kind.Type + type RetType l = DeclExtType + + -- | The return type decoration of branches. + type BranchType l :: Data.Kind.Type + type BranchType l = ExtType + + -- | Extensible operation. + type Op l :: Data.Kind.Type + type Op l = () diff --git a/src/Futhark/IR/Kernels.hs b/src/Futhark/IR/Kernels.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/IR/Kernels.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +-- | A representation with flat parallelism via GPU-oriented kernels. +module Futhark.IR.Kernels + ( -- * The Lore definition + Kernels + -- * Module re-exports + , module Futhark.IR.Prop + , module Futhark.IR.Traversals + , module Futhark.IR.Pretty + , module Futhark.IR.Syntax + , module Futhark.IR.Kernels.Kernel + , module Futhark.IR.Kernels.Sizes + , module Futhark.IR.SOACS.SOAC + ) +where + +import Futhark.IR.Syntax +import Futhark.IR.Kernels.Kernel +import Futhark.IR.Kernels.Sizes +import Futhark.IR.Prop +import Futhark.IR.Traversals +import Futhark.IR.Pretty +import Futhark.IR.SOACS.SOAC hiding (HistOp(..)) +import Futhark.Binder +import Futhark.Construct +import qualified Futhark.TypeCheck as TypeCheck + +-- | The phantom data type for the kernels representation. +data Kernels + +instance Decorations Kernels where + type Op Kernels = HostOp Kernels (SOAC Kernels) +instance ASTLore Kernels where + expTypesFromPattern = return . expExtTypesFromPattern + +instance TypeCheck.CheckableOp Kernels where + checkOp = typeCheckKernelsOp Nothing + where typeCheckKernelsOp lvl = + typeCheckHostOp (typeCheckKernelsOp . Just) lvl typeCheckSOAC + +instance TypeCheck.Checkable Kernels where + +instance Bindable Kernels where + mkBody = Body () + mkExpPat ctx val _ = basicPattern ctx val + mkExpDec _ _ = () + mkLetNames = simpleMkLetNames + +instance BinderOps Kernels where + +instance PrettyLore Kernels where + +instance HasSegOp Kernels where + type SegOpLevel Kernels = SegLevel + asSegOp (SegOp op) = Just op + asSegOp _ = Nothing + segOp = SegOp diff --git a/src/Futhark/IR/Kernels/Kernel.hs b/src/Futhark/IR/Kernels/Kernel.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/IR/Kernels/Kernel.hs @@ -0,0 +1,347 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Futhark.IR.Kernels.Kernel + ( -- * Size operations + SizeOp(..) + + -- * Host operations + , HostOp(..) + , typeCheckHostOp + + -- * SegOp refinements + , SegLevel(..) + + -- * Reexports + , module Futhark.IR.Kernels.Sizes + , module Futhark.IR.SegOp + ) +where + +import Futhark.IR +import qualified Futhark.Analysis.ScalExp as SE +import qualified Futhark.Analysis.SymbolTable as ST +import qualified Futhark.Util.Pretty as PP +import Futhark.Util.Pretty + ((), (<+>), ppr, commasep, parens, text) +import Futhark.Transform.Substitute +import Futhark.Transform.Rename +import Futhark.Optimise.Simplify.Lore +import qualified Futhark.Optimise.Simplify.Engine as Engine +import Futhark.IR.Ranges + (Ranges) +import Futhark.IR.Prop.Ranges +import Futhark.IR.Prop.Aliases +import Futhark.IR.Aliases + (Aliases) +import Futhark.IR.SegOp +import Futhark.IR.Kernels.Sizes +import qualified Futhark.TypeCheck as TC +import Futhark.Analysis.Metrics + +-- | At which level the *body* of a t'SegOp' executes. +data SegLevel = SegThread { segNumGroups :: Count NumGroups SubExp + , segGroupSize :: Count GroupSize SubExp + , segVirt :: SegVirt } + | SegGroup { segNumGroups :: Count NumGroups SubExp + , segGroupSize :: Count GroupSize SubExp + , segVirt :: SegVirt } + deriving (Eq, Ord, Show) + +instance PP.Pretty SegLevel where + ppr lvl = + lvl' + PP.parens (text "#groups=" <> ppr (segNumGroups lvl) <> PP.semi <+> + text "groupsize=" <> ppr (segGroupSize lvl) <> + case segVirt lvl of + SegNoVirt -> mempty + SegNoVirtFull -> PP.semi <+> text "full" + SegVirt -> PP.semi <+> text "virtualise") + + where lvl' = case lvl of SegThread{} -> "_thread" + SegGroup{} -> "_group" + +instance Engine.Simplifiable SegLevel where + simplify (SegThread num_groups group_size virt) = + SegThread <$> traverse Engine.simplify num_groups <*> + traverse Engine.simplify group_size <*> pure virt + simplify (SegGroup num_groups group_size virt) = + SegGroup <$> traverse Engine.simplify num_groups <*> + traverse Engine.simplify group_size <*> pure virt + +instance Substitute SegLevel where + substituteNames substs (SegThread num_groups group_size virt) = + SegThread + (substituteNames substs num_groups) (substituteNames substs group_size) virt + substituteNames substs (SegGroup num_groups group_size virt) = + SegGroup + (substituteNames substs num_groups) (substituteNames substs group_size) virt + +instance Rename SegLevel where + rename = substituteRename + +instance FreeIn SegLevel where + freeIn' (SegThread num_groups group_size _) = + freeIn' num_groups <> freeIn' group_size + freeIn' (SegGroup num_groups group_size _) = + freeIn' num_groups <> freeIn' group_size + +-- | A simple size-level query or computation. +data SizeOp + = SplitSpace SplitOrdering SubExp SubExp SubExp + -- ^ @SplitSpace o w i elems_per_thread@. + -- + -- Computes how to divide array elements to + -- threads in a kernel. Returns the number of + -- elements in the chunk that the current thread + -- should take. + -- + -- @w@ is the length of the outer dimension in + -- the array. @i@ is the current thread + -- index. Each thread takes at most + -- @elems_per_thread@ elements. + -- + -- If the order @o@ is 'SplitContiguous', thread with index @i@ + -- should receive elements + -- @i*elems_per_tread, i*elems_per_thread + 1, + -- ..., i*elems_per_thread + (elems_per_thread-1)@. + -- + -- If the order @o@ is @'SplitStrided' stride@, + -- the thread will receive elements @i, + -- i+stride, i+2*stride, ..., + -- i+(elems_per_thread-1)*stride@. + | GetSize Name SizeClass + -- ^ Produce some runtime-configurable size. + | GetSizeMax SizeClass + -- ^ The maximum size of some class. + | CmpSizeLe Name SizeClass SubExp + -- ^ Compare size (likely a threshold) with some integer value. + | CalcNumGroups SubExp Name SubExp + -- ^ @CalcNumGroups w max_num_groups group_size@ calculates the + -- number of GPU workgroups to use for an input of the given size. + -- The @Name@ is a size name. Note that @w@ is an i64 to avoid + -- overflow issues. + deriving (Eq, Ord, Show) + +instance Substitute SizeOp where + substituteNames subst (SplitSpace o w i elems_per_thread) = + SplitSpace + (substituteNames subst o) + (substituteNames subst w) + (substituteNames subst i) + (substituteNames subst elems_per_thread) + substituteNames substs (CmpSizeLe name sclass x) = + CmpSizeLe name sclass (substituteNames substs x) + substituteNames substs (CalcNumGroups w max_num_groups group_size) = + CalcNumGroups + (substituteNames substs w) + max_num_groups + (substituteNames substs group_size) + substituteNames _ op = op + +instance Rename SizeOp where + rename (SplitSpace o w i elems_per_thread) = + SplitSpace + <$> rename o + <*> rename w + <*> rename i + <*> rename elems_per_thread + rename (CmpSizeLe name sclass x) = + CmpSizeLe name sclass <$> rename x + rename (CalcNumGroups w max_num_groups group_size) = + CalcNumGroups <$> rename w <*> pure max_num_groups <*> rename group_size + rename x = pure x + +instance IsOp SizeOp where + safeOp _ = True + cheapOp _ = True + +instance TypedOp SizeOp where + opType SplitSpace{} = pure [Prim int32] + opType (GetSize _ _) = pure [Prim int32] + opType (GetSizeMax _) = pure [Prim int32] + opType CmpSizeLe{} = pure [Prim Bool] + opType CalcNumGroups{} = pure [Prim int32] + +instance AliasedOp SizeOp where + opAliases _ = [mempty] + consumedInOp _ = mempty + +instance RangedOp SizeOp where + opRanges (SplitSpace _ _ _ elems_per_thread) = + [(Just (ScalarBound 0), + Just (ScalarBound (SE.subExpToScalExp elems_per_thread int32)))] + opRanges _ = [unknownRange] + +instance FreeIn SizeOp where + freeIn' (SplitSpace o w i elems_per_thread) = + freeIn' o <> freeIn' [w, i, elems_per_thread] + freeIn' (CmpSizeLe _ _ x) = freeIn' x + freeIn' (CalcNumGroups w _ group_size) = freeIn' w <> freeIn' group_size + freeIn' _ = mempty + +instance PP.Pretty SizeOp where + ppr (SplitSpace o w i elems_per_thread) = + text "splitSpace" <> suff <> + parens (commasep [ppr w, ppr i, ppr elems_per_thread]) + where suff = case o of SplitContiguous -> mempty + SplitStrided stride -> text "Strided" <> parens (ppr stride) + + ppr (GetSize name size_class) = + text "get_size" <> parens (commasep [ppr name, ppr size_class]) + + ppr (GetSizeMax size_class) = + text "get_size_max" <> parens (commasep [ppr size_class]) + + ppr (CmpSizeLe name size_class x) = + text "get_size" <> parens (commasep [ppr name, ppr size_class]) <+> + text "<=" <+> ppr x + + ppr (CalcNumGroups w max_num_groups group_size) = + text "calc_num_groups" <> parens (commasep [ppr w, ppr max_num_groups, ppr group_size]) + +instance OpMetrics SizeOp where + opMetrics SplitSpace{} = seen "SplitSpace" + opMetrics GetSize{} = seen "GetSize" + opMetrics GetSizeMax{} = seen "GetSizeMax" + opMetrics CmpSizeLe{} = seen "CmpSizeLe" + opMetrics CalcNumGroups{} = seen "CalcNumGroups" + +typeCheckSizeOp :: TC.Checkable lore => SizeOp -> TC.TypeM lore () +typeCheckSizeOp (SplitSpace o w i elems_per_thread) = do + case o of + SplitContiguous -> return () + SplitStrided stride -> TC.require [Prim int32] stride + mapM_ (TC.require [Prim int32]) [w, i, elems_per_thread] +typeCheckSizeOp GetSize{} = return () +typeCheckSizeOp GetSizeMax{} = return () +typeCheckSizeOp (CmpSizeLe _ _ x) = TC.require [Prim int32] x +typeCheckSizeOp (CalcNumGroups w _ group_size) = do TC.require [Prim int64] w + TC.require [Prim int32] group_size + +-- | A host-level operation; parameterised by what else it can do. +data HostOp lore op + = SegOp (SegOp SegLevel lore) + -- ^ A segmented operation. + | SizeOp SizeOp + | OtherOp op + deriving (Eq, Ord, Show) + +instance (ASTLore lore, Substitute op) => Substitute (HostOp lore op) where + substituteNames substs (SegOp op) = + SegOp $ substituteNames substs op + substituteNames substs (OtherOp op) = + OtherOp $ substituteNames substs op + substituteNames substs (SizeOp op) = + SizeOp $ substituteNames substs op + +instance (ASTLore lore, Rename op) => Rename (HostOp lore op) where + rename (SegOp op) = SegOp <$> rename op + rename (OtherOp op) = OtherOp <$> rename op + rename (SizeOp op) = SizeOp <$> rename op + +instance (ASTLore lore, IsOp op) => IsOp (HostOp lore op) where + safeOp (SegOp op) = safeOp op + safeOp (OtherOp op) = safeOp op + safeOp (SizeOp op) = safeOp op + + cheapOp (SegOp op) = cheapOp op + cheapOp (OtherOp op) = cheapOp op + cheapOp (SizeOp op) = cheapOp op + +instance TypedOp op => TypedOp (HostOp lore op) where + opType (SegOp op) = opType op + opType (OtherOp op) = opType op + opType (SizeOp op) = opType op + +instance (Aliased lore, AliasedOp op, ASTLore lore) => AliasedOp (HostOp lore op) where + opAliases (SegOp op) = opAliases op + opAliases (OtherOp op) = opAliases op + opAliases (SizeOp op) = opAliases op + + consumedInOp (SegOp op) = consumedInOp op + consumedInOp (OtherOp op) = consumedInOp op + consumedInOp (SizeOp op) = consumedInOp op + +instance (ASTLore lore, RangedOp op) => RangedOp (HostOp lore op) where + opRanges (SegOp op) = opRanges op + opRanges (OtherOp op) = opRanges op + opRanges (SizeOp op) = opRanges op + +instance (ASTLore lore, FreeIn op) => FreeIn (HostOp lore op) where + freeIn' (SegOp op) = freeIn' op + freeIn' (OtherOp op) = freeIn' op + freeIn' (SizeOp op) = freeIn' op + +instance (CanBeAliased (Op lore), CanBeAliased op, ASTLore lore) => CanBeAliased (HostOp lore op) where + type OpWithAliases (HostOp lore op) = HostOp (Aliases lore) (OpWithAliases op) + + addOpAliases (SegOp op) = SegOp $ addOpAliases op + addOpAliases (OtherOp op) = OtherOp $ addOpAliases op + addOpAliases (SizeOp op) = SizeOp op + + removeOpAliases (SegOp op) = SegOp $ removeOpAliases op + removeOpAliases (OtherOp op) = OtherOp $ removeOpAliases op + removeOpAliases (SizeOp op) = SizeOp op + +instance (CanBeRanged (Op lore), CanBeRanged op, ASTLore lore) => CanBeRanged (HostOp lore op) where + type OpWithRanges (HostOp lore op) = HostOp (Ranges lore) (OpWithRanges op) + + addOpRanges (SegOp op) = SegOp $ addOpRanges op + addOpRanges (OtherOp op) = OtherOp $ addOpRanges op + addOpRanges (SizeOp op) = SizeOp op + + removeOpRanges (SegOp op) = SegOp $ removeOpRanges op + removeOpRanges (OtherOp op) = OtherOp $ removeOpRanges op + removeOpRanges (SizeOp op) = SizeOp op + +instance (CanBeWise (Op lore), CanBeWise op, ASTLore lore) => CanBeWise (HostOp lore op) where + type OpWithWisdom (HostOp lore op) = HostOp (Wise lore) (OpWithWisdom op) + + removeOpWisdom (SegOp op) = SegOp $ removeOpWisdom op + removeOpWisdom (OtherOp op) = OtherOp $ removeOpWisdom op + removeOpWisdom (SizeOp op) = SizeOp op + +instance (ASTLore lore, ST.IndexOp op) => ST.IndexOp (HostOp lore op) where + indexOp vtable k (SegOp op) is = ST.indexOp vtable k op is + indexOp vtable k (OtherOp op) is = ST.indexOp vtable k op is + indexOp _ _ _ _ = Nothing + +instance (PrettyLore lore, PP.Pretty op) => PP.Pretty (HostOp lore op) where + ppr (SegOp op) = ppr op + ppr (OtherOp op) = ppr op + ppr (SizeOp op) = ppr op + +instance (OpMetrics (Op lore), OpMetrics op) => OpMetrics (HostOp lore op) where + opMetrics (SegOp op) = opMetrics op + opMetrics (OtherOp op) = opMetrics op + opMetrics (SizeOp op) = opMetrics op + +checkSegLevel :: Maybe SegLevel -> SegLevel -> TC.TypeM lore () +checkSegLevel Nothing _ = + return () +checkSegLevel (Just SegThread{}) _ = + TC.bad $ TC.TypeError "SegOps cannot occur when already at thread level." +checkSegLevel (Just x) y + | x == y = TC.bad $ TC.TypeError $ "Already at at level " ++ pretty x + | segNumGroups x /= segNumGroups y || segGroupSize x /= segGroupSize y = + TC.bad $ TC.TypeError "Physical layout for SegLevel does not match parent SegLevel." + | otherwise = + return () + +typeCheckHostOp :: TC.Checkable lore => + (SegLevel -> OpWithAliases (Op lore) -> TC.TypeM lore ()) + -> Maybe SegLevel + -> (op -> TC.TypeM lore ()) + -> HostOp (Aliases lore) op + -> TC.TypeM lore () +typeCheckHostOp checker lvl _ (SegOp op) = + TC.checkOpWith (checker $ segLevel op) $ + typeCheckSegOp (checkSegLevel lvl) op +typeCheckHostOp _ _ f (OtherOp op) = f op +typeCheckHostOp _ _ _ (SizeOp op) = typeCheckSizeOp op diff --git a/src/Futhark/IR/Kernels/Simplify.hs b/src/Futhark/IR/Kernels/Simplify.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/IR/Kernels/Simplify.hs @@ -0,0 +1,97 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ConstraintKinds #-} +module Futhark.IR.Kernels.Simplify + ( simplifyKernels + , simplifyLambda + + , Kernels + + -- * Building blocks + , simplifyKernelOp + ) +where + +import Futhark.IR.Kernels +import qualified Futhark.Optimise.Simplify.Engine as Engine +import Futhark.Optimise.Simplify.Rules +import Futhark.Optimise.Simplify.Lore +import Futhark.MonadFreshNames +import Futhark.Tools +import Futhark.Pass +import Futhark.IR.SOACS.Simplify (simplifySOAC) +import qualified Futhark.Optimise.Simplify as Simplify +import Futhark.Optimise.Simplify.Rule +import qualified Futhark.Analysis.SymbolTable as ST +import qualified Futhark.Transform.FirstOrderTransform as FOT + +simpleKernels :: Simplify.SimpleOps Kernels +simpleKernels = Simplify.bindableSimpleOps $ simplifyKernelOp simplifySOAC + +simplifyKernels :: Prog Kernels -> PassM (Prog Kernels) +simplifyKernels = + Simplify.simplifyProg simpleKernels kernelRules Simplify.noExtraHoistBlockers + +simplifyLambda :: (HasScope Kernels m, MonadFreshNames m) => + Lambda Kernels -> [Maybe VName] -> m (Lambda Kernels) +simplifyLambda = + Simplify.simplifyLambda simpleKernels kernelRules Engine.noExtraHoistBlockers + +simplifyKernelOp :: (Engine.SimplifiableLore lore, + BodyDec lore ~ ()) => + Simplify.SimplifyOp lore op + -> HostOp lore op + -> Engine.SimpleM lore (HostOp (Wise lore) (OpWithWisdom op), Stms (Wise lore)) + +simplifyKernelOp f (OtherOp op) = do + (op', stms) <- f op + return (OtherOp op', stms) + +simplifyKernelOp _ (SegOp op) = do + (op', hoisted) <- simplifySegOp op + return (SegOp op', hoisted) + +simplifyKernelOp _ (SizeOp (SplitSpace o w i elems_per_thread)) = + (,) <$> (SizeOp <$> + (SplitSpace <$> Engine.simplify o <*> Engine.simplify w + <*> Engine.simplify i <*> Engine.simplify elems_per_thread)) + <*> pure mempty +simplifyKernelOp _ (SizeOp (GetSize key size_class)) = + return (SizeOp $ GetSize key size_class, mempty) +simplifyKernelOp _ (SizeOp (GetSizeMax size_class)) = + return (SizeOp $ GetSizeMax size_class, mempty) +simplifyKernelOp _ (SizeOp (CmpSizeLe key size_class x)) = do + x' <- Engine.simplify x + return (SizeOp $ CmpSizeLe key size_class x', mempty) +simplifyKernelOp _ (SizeOp (CalcNumGroups w max_num_groups group_size)) = do + w' <- Engine.simplify w + return (SizeOp $ CalcNumGroups w' max_num_groups group_size, mempty) + +instance BinderOps (Wise Kernels) where + +instance HasSegOp (Wise Kernels) where + type SegOpLevel (Wise Kernels) = SegLevel + asSegOp (SegOp op) = Just op + asSegOp _ = Nothing + segOp = SegOp + +kernelRules :: RuleBook (Wise Kernels) +kernelRules = standardRules <> segOpRules <> + ruleBook + [ RuleOp redomapIotaToLoop ] + [ RuleBasicOp removeUnnecessaryCopy ] + +-- We turn reductions over (solely) iotas into do-loops, because there +-- is no useful structure here anyway. This is mostly a hack to work +-- around the fact that loop tiling would otherwise pointlessly tile +-- them. +redomapIotaToLoop :: TopDownRuleOp (Wise Kernels) +redomapIotaToLoop vtable pat aux (OtherOp soac@(Screma _ form [arr])) + | Just _ <- isRedomapSOAC form, + Just (Iota{}, _) <- ST.lookupBasicOp arr vtable = + Simplify $ certifying (stmAuxCerts aux) $ FOT.transformSOAC pat soac +redomapIotaToLoop _ _ _ _ = + Skip diff --git a/src/Futhark/IR/Kernels/Sizes.hs b/src/Futhark/IR/Kernels/Sizes.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/IR/Kernels/Sizes.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE Trustworthy #-} +-- | In the context of this module, a "size" is any kind of tunable +-- (run-time) constant. +module Futhark.IR.Kernels.Sizes + ( SizeClass (..) + , KernelPath + , Count(..) + , NumGroups, GroupSize, NumThreads + ) + where + +import Data.Int (Int32) +import Data.Traversable + +import Futhark.Util.Pretty +import Futhark.Transform.Substitute +import Language.Futhark.Core (Name) +import Futhark.Util.IntegralExp (IntegralExp) +import Futhark.IR.Prop.Names (FreeIn) + +-- | An indication of which comparisons have been performed to get to +-- this point, as well as the result of each comparison. +type KernelPath = [(Name, Bool)] + +-- | The class of some kind of configurable size. Each class may +-- impose constraints on the valid values. +data SizeClass = SizeThreshold KernelPath + | SizeGroup + | SizeNumGroups + | SizeTile + | SizeLocalMemory + -- ^ Likely not useful on its own, but querying the + -- maximum can be handy. + | SizeBespoke Name Int32 + -- ^ A bespoke size with a default. + deriving (Eq, Ord, Show) + +instance Pretty SizeClass where + ppr (SizeThreshold path) = text $ "threshold (" ++ unwords (map pStep path) ++ ")" + where pStep (v, True) = pretty v + pStep (v, False) = '!' : pretty v + ppr SizeGroup = text "group_size" + ppr SizeNumGroups = text "num_groups" + ppr SizeTile = text "tile_size" + ppr SizeLocalMemory = text "local_memory" + ppr (SizeBespoke k _) = ppr k + +-- | A wrapper supporting a phantom type for indicating what we are counting. +newtype Count u e = Count { unCount :: e } + deriving (Eq, Ord, Show, Num, IntegralExp, FreeIn, Pretty, Substitute) + +instance Functor (Count u) where + fmap = fmapDefault + +instance Foldable (Count u) where + foldMap = foldMapDefault + +instance Traversable (Count u) where + traverse f (Count x) = Count <$> f x + +-- | Phantom type for the number of groups of some kernel. +data NumGroups + +-- | Phantom type for the group size of some kernel. +data GroupSize + +-- | Phantom type for number of threads. +data NumThreads diff --git a/src/Futhark/IR/KernelsMem.hs b/src/Futhark/IR/KernelsMem.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/IR/KernelsMem.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ConstraintKinds #-} +module Futhark.IR.KernelsMem + ( KernelsMem + + -- * Simplification + , simplifyProg + , simplifyStms + , simpleKernelsMem + + -- * Module re-exports + , module Futhark.IR.Mem + , module Futhark.IR.Kernels.Kernel + ) + where + +import Futhark.Analysis.PrimExp.Convert +import Futhark.MonadFreshNames +import Futhark.Pass +import Futhark.IR.Syntax +import Futhark.IR.Prop +import Futhark.IR.Traversals +import Futhark.IR.Pretty +import Futhark.IR.Kernels.Kernel +import Futhark.IR.Kernels.Simplify (simplifyKernelOp) +import qualified Futhark.TypeCheck as TC +import Futhark.IR.Mem +import Futhark.IR.Mem.Simplify +import Futhark.Pass.ExplicitAllocations (BinderOps(..), mkLetNamesB', mkLetNamesB'') +import qualified Futhark.Optimise.Simplify.Engine as Engine + +data KernelsMem + +instance Decorations KernelsMem where + type LetDec KernelsMem = LetDecMem + type FParamInfo KernelsMem = FParamMem + type LParamInfo KernelsMem = LParamMem + type RetType KernelsMem = RetTypeMem + type BranchType KernelsMem = BranchTypeMem + type Op KernelsMem = MemOp (HostOp KernelsMem ()) + +instance ASTLore KernelsMem where + expTypesFromPattern = return . map snd . snd . bodyReturnsFromPattern + +instance OpReturns KernelsMem where + opReturns (Alloc _ space) = + return [MemMem space] + opReturns (Inner (SegOp op)) = segOpReturns op + opReturns k = extReturns <$> opType k + +instance PrettyLore KernelsMem where + +instance TC.CheckableOp KernelsMem where + checkOp = typeCheckMemoryOp Nothing + where typeCheckMemoryOp _ (Alloc size _) = + TC.require [Prim int64] size + typeCheckMemoryOp lvl (Inner op) = + typeCheckHostOp (typeCheckMemoryOp . Just) lvl (const $ return ()) op + +instance TC.Checkable KernelsMem where + checkFParamLore = checkMemInfo + checkLParamLore = checkMemInfo + checkLetBoundLore = checkMemInfo + checkRetType = mapM_ $ TC.checkExtType . declExtTypeOf + primFParam name t = return $ Param name (MemPrim t) + matchPattern = matchPatternToExp + matchReturnType = matchFunctionReturnType + matchBranchType = matchBranchReturnType + +instance BinderOps KernelsMem where + mkExpDecB _ _ = return () + mkBodyB stms res = return $ Body () stms res + mkLetNamesB = mkLetNamesB' () + +instance BinderOps (Engine.Wise KernelsMem) where + mkExpDecB pat e = return $ Engine.mkWiseExpDec pat () e + mkBodyB stms res = return $ Engine.mkWiseBody () stms res + mkLetNamesB = mkLetNamesB'' + +simplifyProg :: Prog KernelsMem -> PassM (Prog KernelsMem) +simplifyProg = + simplifyProgGeneric $ simplifyKernelOp $ const $ return ((), mempty) + +simplifyStms :: (HasScope KernelsMem m, MonadFreshNames m) => + Stms KernelsMem + -> m (Engine.SymbolTable (Engine.Wise KernelsMem), + Stms KernelsMem) +simplifyStms = + simplifyStmsGeneric $ simplifyKernelOp $ const $ return ((), mempty) + +simpleKernelsMem :: Engine.SimpleOps KernelsMem +simpleKernelsMem = + simpleGeneric $ simplifyKernelOp $ const $ return ((), mempty) diff --git a/src/Futhark/IR/Mem.hs b/src/Futhark/IR/Mem.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/IR/Mem.hs @@ -0,0 +1,997 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ConstraintKinds #-} +-- | Building blocks for defining representations where every array +-- is given information about which memory block is it based in, and +-- how array elements map to memory block offsets. +-- +-- There are two primary concepts you will need to understand: +-- +-- 1. Memory blocks, which are Futhark values of type v'Mem' +-- (parametrized with their size). These correspond to arbitrary +-- blocks of memory, and are created using the 'Alloc' operation. +-- +-- 2. Index functions, which describe a mapping from the index space +-- of an array (eg. a two-dimensional space for an array of type +-- @[[int]]@) to a one-dimensional offset into a memory block. +-- Thus, index functions describe how arbitrary-dimensional arrays +-- are mapped to the single-dimensional world of memory. +-- +-- At a conceptual level, imagine that we have a two-dimensional array +-- @a@ of 32-bit integers, consisting of @n@ rows of @m@ elements +-- each. This array could be represented in classic row-major format +-- with an index function like the following: +-- +-- @ +-- f(i,j) = i * m + j +-- @ +-- +-- When we want to know the location of element @a[2,3]@, we simply +-- call the index function as @f(2,3)@ and obtain @2*m+3@. We could +-- also have chosen another index function, one that represents the +-- array in column-major (or "transposed") format: +-- +-- @ +-- f(i,j) = j * n + i +-- @ +-- +-- Index functions are not Futhark-level functions, but a special +-- construct that the final code generator will eventually use to +-- generate concrete access code. By modifying the index functions we +-- can change how an array is represented in memory, which can permit +-- memory access pattern optimisations. +-- +-- Every time we bind an array, whether in a @let@-binding, @loop@ +-- merge parameter, or @lambda@ parameter, we have an annotation +-- specifying a memory block and an index function. In some cases, +-- such as @let@-bindings for many expressions, we are free to specify +-- an arbitrary index function and memory block - for example, we get +-- to decide where 'Copy' stores its result - but in other cases the +-- type rules of the expression chooses for us. For example, 'Index' +-- always produces an array in the same memory block as its input, and +-- with the same index function, except with some indices fixed. +module Futhark.IR.Mem + ( LetDecMem + , FParamMem + , LParamMem + , RetTypeMem + , BranchTypeMem + + , MemOp (..) + , MemInfo (..) + , MemBound + , MemBind (..) + , MemReturn (..) + , IxFun + , ExtIxFun + , isStaticIxFun + , ExpReturns + , BodyReturns + , FunReturns + , noUniquenessReturns + , bodyReturnsToExpReturns + , Mem + , AllocOp(..) + , OpReturns(..) + , varReturns + , expReturns + , extReturns + , lookupMemInfo + , subExpMemInfo + , lookupArraySummary + , existentialiseIxFun + + -- * Type checking parts + , matchBranchReturnType + , matchPatternToExp + , matchFunctionReturnType + , bodyReturnsFromPattern + , checkMemInfo + + -- * Module re-exports + , module Futhark.IR.Prop + , module Futhark.IR.Traversals + , module Futhark.IR.Pretty + , module Futhark.IR.Syntax + , module Futhark.Analysis.PrimExp.Convert + ) +where + +import Data.Maybe +import Control.Monad.State +import Control.Monad.Reader +import Control.Monad.Except +import qualified Data.Map.Strict as M +import Data.Foldable (traverse_, toList) +import Data.List (find) +import qualified Data.Set as S + +import Futhark.Analysis.Metrics +import Futhark.IR.Syntax +import Futhark.IR.Prop +import Futhark.IR.Prop.Aliases +import Futhark.IR.Traversals +import Futhark.IR.Pretty +import Futhark.Transform.Rename +import Futhark.Transform.Substitute +import qualified Futhark.TypeCheck as TC +import qualified Futhark.IR.Mem.IxFun as IxFun +import Futhark.Analysis.PrimExp.Convert +import Futhark.Analysis.PrimExp.Simplify +import Futhark.Util +import qualified Futhark.Util.Pretty as PP +import qualified Futhark.Optimise.Simplify.Engine as Engine +import Futhark.Optimise.Simplify.Lore +import Futhark.IR.Aliases + (Aliases, removeScopeAliases, removeExpAliases, removePatternAliases) +import Futhark.IR.Prop.Ranges +import qualified Futhark.Analysis.SymbolTable as ST + +type LetDecMem = MemInfo SubExp NoUniqueness MemBind +type FParamMem = MemInfo SubExp Uniqueness MemBind +type LParamMem = MemInfo SubExp NoUniqueness MemBind +type RetTypeMem = FunReturns +type BranchTypeMem = BodyReturns + +-- | The class of ops that have memory allocation. +class AllocOp op where + allocOp :: SubExp -> Space -> op + +type Mem lore = (AllocOp (Op lore), + FParamInfo lore ~ FParamMem, + LParamInfo lore ~ LParamMem, + LetDec lore ~ LetDecMem, + RetType lore ~ RetTypeMem, + BranchType lore ~ BranchTypeMem, + CanBeAliased (Op lore), + ASTLore lore, Decorations lore, + TC.Checkable lore, + OpReturns lore) + +instance IsRetType FunReturns where + primRetType = MemPrim + applyRetType = applyFunReturns + +instance IsBodyType BodyReturns where + primBodyType = MemPrim + +data MemOp inner = Alloc SubExp Space + -- ^ Allocate a memory block. This really should not be an + -- expression, but what are you gonna do... + | Inner inner + deriving (Eq, Ord, Show) + +instance AllocOp (MemOp inner) where + allocOp = Alloc + +instance FreeIn inner => FreeIn (MemOp inner) where + freeIn' (Alloc size _) = freeIn' size + freeIn' (Inner k) = freeIn' k + +instance TypedOp inner => TypedOp (MemOp inner) where + opType (Alloc _ space) = pure [Mem space] + opType (Inner k) = opType k + +instance AliasedOp inner => AliasedOp (MemOp inner) where + opAliases Alloc{} = [mempty] + opAliases (Inner k) = opAliases k + + consumedInOp Alloc{} = mempty + consumedInOp (Inner k) = consumedInOp k + +instance CanBeAliased inner => CanBeAliased (MemOp inner) where + type OpWithAliases (MemOp inner) = MemOp (OpWithAliases inner) + removeOpAliases (Alloc se space) = Alloc se space + removeOpAliases (Inner k) = Inner $ removeOpAliases k + + addOpAliases (Alloc se space) = Alloc se space + addOpAliases (Inner k) = Inner $ addOpAliases k + +instance RangedOp inner => RangedOp (MemOp inner) where + opRanges (Alloc _ _) = + [unknownRange] + opRanges (Inner k) = + opRanges k + +instance CanBeRanged inner => CanBeRanged (MemOp inner) where + type OpWithRanges (MemOp inner) = MemOp (OpWithRanges inner) + removeOpRanges (Alloc size space) = Alloc size space + removeOpRanges (Inner k) = Inner $ removeOpRanges k + + addOpRanges (Alloc size space) = Alloc size space + addOpRanges (Inner k) = Inner $ addOpRanges k + +instance Rename inner => Rename (MemOp inner) where + rename (Alloc size space) = Alloc <$> rename size <*> pure space + rename (Inner k) = Inner <$> rename k + +instance Substitute inner => Substitute (MemOp inner) where + substituteNames subst (Alloc size space) = Alloc (substituteNames subst size) space + substituteNames subst (Inner k) = Inner $ substituteNames subst k + +instance PP.Pretty inner => PP.Pretty (MemOp inner) where + ppr (Alloc e DefaultSpace) = PP.text "alloc" <> PP.apply [PP.ppr e] + ppr (Alloc e s) = PP.text "alloc" <> PP.apply [PP.ppr e, PP.ppr s] + ppr (Inner k) = PP.ppr k + +instance OpMetrics inner => OpMetrics (MemOp inner) where + opMetrics Alloc{} = seen "Alloc" + opMetrics (Inner k) = opMetrics k + +instance IsOp inner => IsOp (MemOp inner) where + safeOp Alloc{} = False + safeOp (Inner k) = safeOp k + cheapOp (Inner k) = cheapOp k + cheapOp Alloc{} = True + +instance CanBeWise inner => CanBeWise (MemOp inner) where + type OpWithWisdom (MemOp inner) = MemOp (OpWithWisdom inner) + removeOpWisdom (Alloc size space) = Alloc size space + removeOpWisdom (Inner k) = Inner $ removeOpWisdom k + +instance ST.IndexOp inner => ST.IndexOp (MemOp inner) where + indexOp vtable k (Inner op) is = ST.indexOp vtable k op is + indexOp _ _ _ _ = Nothing + +-- | The index function representation used for memory annotations. +type IxFun = IxFun.IxFun (PrimExp VName) + +-- | An index function that may contain existential variables. +type ExtIxFun = IxFun.IxFun (PrimExp (Ext VName)) + +-- | A summary of the memory information for every let-bound +-- identifier, function parameter, and return value. Parameterisered +-- over uniqueness, dimension, and auxiliary array information. +data MemInfo d u ret = MemPrim PrimType + -- ^ A primitive value. + | MemMem Space + -- ^ A memory block. + | MemArray PrimType (ShapeBase d) u ret + -- ^ The array is stored in the named memory block, + -- and with the given index function. The index + -- function maps indices in the array to /element/ + -- offset, /not/ byte offsets! To translate to byte + -- offsets, multiply the offset with the size of the + -- array element type. + deriving (Eq, Show, Ord) --- XXX Ord? + +type MemBound u = MemInfo SubExp u MemBind + +instance FixExt ret => DeclExtTyped (MemInfo ExtSize Uniqueness ret) where + declExtTypeOf (MemPrim pt) = Prim pt + declExtTypeOf (MemMem space) = Mem space + declExtTypeOf (MemArray pt shape u _) = Array pt shape u + +instance FixExt ret => ExtTyped (MemInfo ExtSize NoUniqueness ret) where + extTypeOf (MemPrim pt) = Prim pt + extTypeOf (MemMem space) = Mem space + extTypeOf (MemArray pt shape u _) = Array pt shape u + +instance FixExt ret => FixExt (MemInfo ExtSize u ret) where + fixExt _ _ (MemPrim pt) = MemPrim pt + fixExt _ _ (MemMem space) = MemMem space + fixExt i se (MemArray pt shape u ret) = + MemArray pt (fixExt i se shape) u (fixExt i se ret) + +instance Typed (MemInfo SubExp Uniqueness ret) where + typeOf = fromDecl . declTypeOf + +instance Typed (MemInfo SubExp NoUniqueness ret) where + typeOf (MemPrim pt) = Prim pt + typeOf (MemMem space) = Mem space + typeOf (MemArray bt shape u _) = Array bt shape u + +instance DeclTyped (MemInfo SubExp Uniqueness ret) where + declTypeOf (MemPrim bt) = Prim bt + declTypeOf (MemMem space) = Mem space + declTypeOf (MemArray bt shape u _) = Array bt shape u + +instance (FreeIn d, FreeIn ret) => FreeIn (MemInfo d u ret) where + freeIn' (MemArray _ shape _ ret) = freeIn' shape <> freeIn' ret + freeIn' (MemMem s) = freeIn' s + freeIn' MemPrim{} = mempty + +instance (Substitute d, Substitute ret) => Substitute (MemInfo d u ret) where + substituteNames subst (MemArray bt shape u ret) = + MemArray bt + (substituteNames subst shape) u + (substituteNames subst ret) + substituteNames _ (MemMem space) = + MemMem space + substituteNames _ (MemPrim bt) = + MemPrim bt + +instance (Substitute d, Substitute ret) => Rename (MemInfo d u ret) where + rename = substituteRename + +simplifyIxFun :: Engine.SimplifiableLore lore => + IxFun -> Engine.SimpleM lore IxFun +simplifyIxFun = traverse simplifyPrimExp + +simplifyExtIxFun :: Engine.SimplifiableLore lore => + ExtIxFun -> Engine.SimpleM lore ExtIxFun +simplifyExtIxFun = traverse simplifyExtPrimExp + +isStaticIxFun :: ExtIxFun -> Maybe IxFun +isStaticIxFun = traverse $ traverse inst + where inst Ext{} = Nothing + inst (Free x) = Just x + +instance (Engine.Simplifiable d, Engine.Simplifiable ret) => + Engine.Simplifiable (MemInfo d u ret) where + simplify (MemPrim bt) = + return $ MemPrim bt + simplify (MemMem space) = + pure $ MemMem space + simplify (MemArray bt shape u ret) = + MemArray bt <$> Engine.simplify shape <*> pure u <*> Engine.simplify ret + +instance (PP.Pretty (TypeBase (ShapeBase d) u), + PP.Pretty d, PP.Pretty u, PP.Pretty ret) => PP.Pretty (MemInfo d u ret) where + ppr (MemPrim bt) = PP.ppr bt + ppr (MemMem DefaultSpace) = PP.text "mem" + ppr (MemMem s) = PP.text "mem" <> PP.ppr s + ppr (MemArray bt shape u ret) = + PP.ppr (Array bt shape u) <> PP.text "@" <> PP.ppr ret + +instance PP.Pretty (Param (MemInfo SubExp Uniqueness ret)) where + ppr = PP.ppr . fmap declTypeOf + +instance PP.Pretty (Param (MemInfo SubExp NoUniqueness ret)) where + ppr = PP.ppr . fmap typeOf + +instance PP.Pretty (PatElemT (MemInfo SubExp NoUniqueness ret)) where + ppr = PP.ppr . fmap typeOf + +-- | Memory information for an array bound somewhere in the program. +data MemBind = ArrayIn VName IxFun + -- ^ Located in this memory block with this index + -- function. + deriving (Show) + +instance Eq MemBind where + _ == _ = True + +instance Ord MemBind where + _ `compare` _ = EQ + +instance Rename MemBind where + rename = substituteRename + +instance Substitute MemBind where + substituteNames substs (ArrayIn ident ixfun) = + ArrayIn (substituteNames substs ident) (substituteNames substs ixfun) + +instance PP.Pretty MemBind where + ppr (ArrayIn mem ixfun) = + PP.text "@" <> PP.ppr mem <> PP.text "->" <> PP.ppr ixfun + +instance FreeIn MemBind where + freeIn' (ArrayIn mem ixfun) = freeIn' mem <> freeIn' ixfun + +-- | A description of the memory properties of an array being returned +-- by an operation. +data MemReturn = ReturnsInBlock VName ExtIxFun + -- ^ The array is located in a memory block that is + -- already in scope. + | ReturnsNewBlock Space Int ExtIxFun + -- ^ The operation returns a new (existential) memory + -- block. + deriving (Show) + +instance Eq MemReturn where + _ == _ = True + +instance Ord MemReturn where + _ `compare` _ = EQ + +instance Rename MemReturn where + rename = substituteRename + +instance Substitute MemReturn where + substituteNames substs (ReturnsInBlock ident ixfun) = + ReturnsInBlock (substituteNames substs ident) (substituteNames substs ixfun) + substituteNames substs (ReturnsNewBlock space i ixfun) = + ReturnsNewBlock space i (substituteNames substs ixfun) + +instance FixExt MemReturn where + fixExt i (Var v) (ReturnsNewBlock _ j ixfun) + | j == i = ReturnsInBlock v $ fixExtIxFun i + (primExpFromSubExp int32 (Var v)) ixfun + fixExt i se (ReturnsNewBlock space j ixfun) = + ReturnsNewBlock space j' + (fixExtIxFun i (primExpFromSubExp int32 se) ixfun) + where j' | i < j = j-1 + | otherwise = j + fixExt i se (ReturnsInBlock mem ixfun) = + ReturnsInBlock mem (fixExtIxFun i (primExpFromSubExp int32 se) ixfun) + +fixExtIxFun :: Int -> PrimExp VName -> ExtIxFun -> ExtIxFun +fixExtIxFun i e = fmap $ replaceInPrimExp update + where update (Ext j) t | j > i = LeafExp (Ext $ j - 1) t + | j == i = fmap Free e + | otherwise = LeafExp (Ext j) t + update (Free x) t = LeafExp (Free x) t + +leafExp :: Int -> PrimExp (Ext a) +leafExp i = LeafExp (Ext i) int32 + +existentialiseIxFun :: [VName] -> IxFun -> ExtIxFun +existentialiseIxFun ctx = IxFun.substituteInIxFun ctx' . fmap (fmap Free) + where ctx' = M.map leafExp $ M.fromList $ zip (map Free ctx) [0..] + +instance PP.Pretty MemReturn where + ppr (ReturnsInBlock v ixfun) = + PP.parens $ PP.text (pretty v) <> PP.text "->" <> PP.ppr ixfun + ppr (ReturnsNewBlock space i ixfun) = + PP.text ("?" ++ show i) <> PP.ppr space <> PP.text "->" <> PP.ppr ixfun + +instance FreeIn MemReturn where + freeIn' (ReturnsInBlock v ixfun) = freeIn' v <> freeIn' ixfun + freeIn' _ = mempty + +instance Engine.Simplifiable MemReturn where + simplify (ReturnsNewBlock space i ixfun) = + ReturnsNewBlock space i <$> simplifyExtIxFun ixfun + simplify (ReturnsInBlock v ixfun) = + ReturnsInBlock <$> Engine.simplify v <*> simplifyExtIxFun ixfun + + +instance Engine.Simplifiable MemBind where + simplify (ArrayIn mem ixfun) = + ArrayIn <$> Engine.simplify mem <*> simplifyIxFun ixfun + +instance Engine.Simplifiable [FunReturns] where + simplify = mapM Engine.simplify + +-- | The memory return of an expression. An array is annotated with +-- @Maybe MemReturn@, which can be interpreted as the expression +-- either dictating exactly where the array is located when it is +-- returned (if 'Just'), or able to put it whereever the binding +-- prefers (if 'Nothing'). +-- +-- This is necessary to capture the difference between an expression +-- that is just an array-typed variable, in which the array being +-- "returned" is located where it already is, and a @copy@ expression, +-- whose entire purpose is to store an existing array in some +-- arbitrary location. This is a consequence of the design decision +-- never to have implicit memory copies. +type ExpReturns = MemInfo ExtSize NoUniqueness (Maybe MemReturn) + +-- | The return of a body, which must always indicate where +-- returned arrays are located. +type BodyReturns = MemInfo ExtSize NoUniqueness MemReturn + +-- | The memory return of a function, which must always indicate where +-- returned arrays are located. +type FunReturns = MemInfo ExtSize Uniqueness MemReturn + +maybeReturns :: MemInfo d u r -> MemInfo d u (Maybe r) +maybeReturns (MemArray bt shape u ret) = + MemArray bt shape u $ Just ret +maybeReturns (MemPrim bt) = + MemPrim bt +maybeReturns (MemMem space) = + MemMem space + +noUniquenessReturns :: MemInfo d u r -> MemInfo d NoUniqueness r +noUniquenessReturns (MemArray bt shape _ r) = + MemArray bt shape NoUniqueness r +noUniquenessReturns (MemPrim bt) = + MemPrim bt +noUniquenessReturns (MemMem space) = + MemMem space + +funReturnsToExpReturns :: FunReturns -> ExpReturns +funReturnsToExpReturns = noUniquenessReturns . maybeReturns + +bodyReturnsToExpReturns :: BodyReturns -> ExpReturns +bodyReturnsToExpReturns = noUniquenessReturns . maybeReturns + +matchFunctionReturnType :: Mem lore => + [FunReturns] -> Result -> TC.TypeM lore () +matchFunctionReturnType rettype result = do + scope <- askScope + result_ts <- runReaderT (mapM subExpMemInfo result) $ removeScopeAliases scope + matchReturnType rettype result result_ts + mapM_ checkResultSubExp result + where checkResultSubExp Constant{} = + return () + checkResultSubExp (Var v) = do + dec <- varMemInfo v + case dec of + MemPrim _ -> return () + MemMem{} -> return () + MemArray _ _ _ (ArrayIn _ ixfun) + | IxFun.isLinear ixfun -> + return () + | otherwise -> + TC.bad $ TC.TypeError $ + "Array " ++ pretty v ++ + " returned by function, but has nontrivial index function " ++ + pretty ixfun + +matchBranchReturnType :: Mem lore => + [BodyReturns] + -> Body (Aliases lore) + -> TC.TypeM lore () +matchBranchReturnType rettype (Body _ stms res) = do + scope <- askScope + ts <- runReaderT (mapM subExpMemInfo res) $ removeScopeAliases (scope <> scopeOf stms) + matchReturnType rettype res ts + +-- | Helper function for index function unification. +-- +-- The first return value maps a VName (wrapped in 'Free') to its Int +-- (wrapped in 'Ext'). In case of duplicates, it is mapped to the +-- *first* Int that occurs. +-- +-- The second return value maps each Int (wrapped in an 'Ext') to a +-- 'LeafExp' 'Ext' with the Int at which its associated VName first +-- occurs. +getExtMaps :: [(VName,Int)] -> (M.Map (Ext VName) (PrimExp (Ext VName)), + M.Map (Ext VName) (PrimExp (Ext VName))) +getExtMaps ctx_lst_ids = + (M.map leafExp $ M.mapKeys Free $ M.fromListWith (flip const) ctx_lst_ids, + M.fromList $ + mapMaybe (traverse (fmap (\i -> LeafExp (Ext i) int32) . + (`lookup` ctx_lst_ids)) . + uncurry (flip (,)) . fmap Ext) ctx_lst_ids) + +matchReturnType :: PP.Pretty u => + [MemInfo ExtSize u MemReturn] + -> [SubExp] + -> [MemInfo SubExp NoUniqueness MemBind] + -> TC.TypeM lore () +matchReturnType rettype res ts = do + let (ctx_ts, val_ts) = splitFromEnd (length rettype) ts + (ctx_res, _val_res) = splitFromEnd (length rettype) res + + existentialiseIxFun0 :: IxFun -> ExtIxFun + existentialiseIxFun0 = fmap $ fmap Free + + fetchCtx i = case maybeNth i $ zip ctx_res ctx_ts of + Nothing -> throwError $ "Cannot find context variable " ++ + show i ++ " in context results: " ++ pretty ctx_res + Just (se, t) -> return (se, t) + + checkReturn (MemPrim x) (MemPrim y) + | x == y = return () + checkReturn (MemMem x) (MemMem y) + | x == y = return () + checkReturn (MemArray x_pt x_shape _ x_ret) + (MemArray y_pt y_shape _ y_ret) + | x_pt == y_pt, shapeRank x_shape == shapeRank y_shape = do + zipWithM_ checkDim (shapeDims x_shape) (shapeDims y_shape) + checkMemReturn x_ret y_ret + checkReturn x y = + throwError $ unwords ["Expected ", pretty x, " but got ", pretty y] + + checkDim (Free x) y + | x == y = return () + | otherwise = throwError $ unwords ["Expected dim", pretty x, + "but got", pretty y] + checkDim (Ext i) y = do + (x, _) <- fetchCtx i + unless (x == y) $ + throwError $ unwords ["Expected ext dim", pretty i, "=>", pretty x, + "but got", pretty y] + + extsInMemInfo :: MemInfo ExtSize u MemReturn -> S.Set Int + extsInMemInfo (MemArray _ shp _ ret) = + extInShape shp <> extInMemReturn ret + extsInMemInfo _ = S.empty + + checkMemReturn (ReturnsInBlock x_mem x_ixfun) (ArrayIn y_mem y_ixfun) + | x_mem == y_mem = + unless (IxFun.closeEnough x_ixfun $ existentialiseIxFun0 y_ixfun) $ + throwError $ unwords ["Index function unification failed (ReturnsInBlock)", + "\nixfun of body result: ", pretty y_ixfun, + "\nixfun of return type: ", pretty x_ixfun, + "\nand context elements: ", pretty ctx_res] + checkMemReturn (ReturnsNewBlock x_space x_ext x_ixfun) + (ArrayIn y_mem y_ixfun) = do + (x_mem, x_mem_type) <- fetchCtx x_ext + unless (IxFun.closeEnough x_ixfun $ existentialiseIxFun0 y_ixfun) $ + throwError $ unwords ["Index function unification failed (ReturnsNewBlock)", + "\nixfun of body result: ", pretty y_ixfun, + "\nixfun of return type: ", pretty x_ixfun, + "\nand context elements: ", pretty ctx_res] + case x_mem_type of + MemMem y_space -> do + unless (x_mem == Var y_mem) $ + throwError $ unwords ["Expected memory", pretty x_ext, "=>", pretty x_mem, + "but got", pretty y_mem] + unless (x_space == y_space) $ + throwError $ unwords ["Expected memory", pretty y_mem, "in space", pretty x_space, + "but actually in space", pretty y_space] + t -> + throwError $ unwords ["Expected memory", pretty x_ext, "=>", pretty x_mem, + "but but has type", pretty t] + checkMemReturn x y = + throwError $ unwords ["Expected array in", pretty x, + "but array returned in", pretty y] + + bad :: String -> TC.TypeM lore a + bad s = TC.bad $ TC.TypeError $ + unlines [ "Return type" + , " " ++ prettyTuple rettype + , "cannot match returns of results" + , " " ++ prettyTuple ts + , s + ] + + unless (length (S.unions $ map extsInMemInfo rettype) == length ctx_res) $ + TC.bad $ TC.TypeError $ "Too many context parameters for the number of " ++ + "existentials in the return type! type:\n " ++ + prettyTuple rettype ++ + "\ncannot match context parameters:\n " ++ prettyTuple ctx_res + + + either bad return =<< runExceptT (zipWithM_ checkReturn rettype val_ts) + +matchPatternToExp :: (Mem lore) => + Pattern (Aliases lore) + -> Exp (Aliases lore) + -> TC.TypeM lore () +matchPatternToExp pat e = do + scope <- asksScope removeScopeAliases + rt <- runReaderT (expReturns $ removeExpAliases e) scope + + let (ctxs, vals) = bodyReturnsFromPattern $ removePatternAliases pat + (ctx_ids, _ctx_ts) = unzip ctxs + (_val_ids, val_ts) = unzip vals + (ctx_map_ids, ctx_map_exts) = + getExtMaps $ zip ctx_ids [0..length ctx_ids - 1] + + let rt_exts = foldMap extInExpReturns rt + + unless (length val_ts == length rt && + and (zipWith (matches ctx_map_ids ctx_map_exts) val_ts rt) && + M.keysSet ctx_map_exts `S.isSubsetOf` S.map Ext rt_exts) $ + TC.bad $ TC.TypeError $ "Expression type:\n " ++ prettyTuple rt ++ + "\ncannot match pattern type:\n " ++ prettyTuple val_ts ++ + "\nwith context elements: " ++ pretty ctx_ids + where matches _ _ (MemPrim x) (MemPrim y) = x == y + matches _ _ (MemMem x_space) (MemMem y_space) = + x_space == y_space + matches ctxids ctxexts (MemArray x_pt x_shape _ x_ret) (MemArray y_pt y_shape _ y_ret) = + x_pt == y_pt && x_shape == y_shape && + case (x_ret, y_ret) of + (ReturnsInBlock x_mem x_ixfun, Just (ReturnsInBlock y_mem y_ixfun)) -> + let x_ixfun' = IxFun.substituteInIxFun ctxids x_ixfun + y_ixfun' = IxFun.substituteInIxFun ctxexts y_ixfun + in x_mem == y_mem && x_ixfun' == y_ixfun' + (ReturnsInBlock _ x_ixfun, + Just (ReturnsNewBlock _ _ y_ixfun)) -> + let x_ixfun' = IxFun.substituteInIxFun ctxids x_ixfun + y_ixfun' = IxFun.substituteInIxFun ctxexts y_ixfun + in x_ixfun' == y_ixfun' + (ReturnsNewBlock x_space x_i x_ixfun, + Just (ReturnsNewBlock y_space y_i y_ixfun)) -> + let x_ixfun' = IxFun.substituteInIxFun ctxids x_ixfun + y_ixfun' = IxFun.substituteInIxFun ctxexts y_ixfun + in x_space == y_space && x_i == y_i && IxFun.closeEnough x_ixfun' y_ixfun' + (_, Nothing) -> True + _ -> False + matches _ _ _ _ = False + + extInExpReturns :: ExpReturns -> S.Set Int + extInExpReturns (MemArray _ shape _ mem_return) = + extInShape shape <> maybe S.empty extInMemReturn mem_return + extInExpReturns _ = mempty + + +extInShape :: ShapeBase (Ext SubExp) -> S.Set Int +extInShape shape = S.fromList $ mapMaybe isExt $ shapeDims shape + +extInMemReturn :: MemReturn -> S.Set Int +extInMemReturn (ReturnsInBlock _ extixfn) = extInIxFn extixfn +extInMemReturn (ReturnsNewBlock _ i extixfn) = + S.singleton i <> extInIxFn extixfn + +extInIxFn :: ExtIxFun -> S.Set Int +extInIxFn ixfun = S.fromList $ concatMap (mapMaybe isExt . toList) ixfun + +varMemInfo :: Mem lore => + VName -> TC.TypeM lore (MemInfo SubExp NoUniqueness MemBind) +varMemInfo name = do + dec <- TC.lookupVar name + + case dec of + LetName (_, summary) -> return summary + FParamName summary -> return $ noUniquenessReturns summary + LParamName summary -> return summary + IndexName it -> return $ MemPrim $ IntType it + +nameInfoToMemInfo :: Mem lore => NameInfo lore -> MemBound NoUniqueness +nameInfoToMemInfo info = + case info of + FParamName summary -> noUniquenessReturns summary + LParamName summary -> summary + LetName summary -> summary + IndexName it -> MemPrim $ IntType it + +lookupMemInfo :: (HasScope lore m, Mem lore) => + VName -> m (MemInfo SubExp NoUniqueness MemBind) +lookupMemInfo = fmap nameInfoToMemInfo . lookupInfo + +subExpMemInfo :: (HasScope lore m, Monad m, Mem lore) => + SubExp -> m (MemInfo SubExp NoUniqueness MemBind) +subExpMemInfo (Var v) = lookupMemInfo v +subExpMemInfo (Constant v) = return $ MemPrim $ primValueType v + +lookupArraySummary :: (Mem lore, HasScope lore m, Monad m) => + VName -> m (VName, IxFun.IxFun (PrimExp VName)) +lookupArraySummary name = do + summary <- lookupMemInfo name + case summary of + MemArray _ _ _ (ArrayIn mem ixfun) -> + return (mem, ixfun) + _ -> + error $ "Variable " ++ pretty name ++ " does not look like an array." + +checkMemInfo :: TC.Checkable lore => + VName -> MemInfo SubExp u MemBind + -> TC.TypeM lore () +checkMemInfo _ (MemPrim _) = return () +checkMemInfo _ (MemMem (ScalarSpace d _)) = mapM_ (TC.require [Prim int32]) d +checkMemInfo _ (MemMem _) = return () +checkMemInfo name (MemArray _ shape _ (ArrayIn v ixfun)) = do + t <- lookupType v + case t of + Mem{} -> + return () + _ -> + TC.bad $ TC.TypeError $ + "Variable " ++ pretty v ++ + " used as memory block, but is of type " ++ + pretty t ++ "." + + TC.context ("in index function " ++ pretty ixfun) $ do + traverse_ (TC.requirePrimExp int32) ixfun + let ixfun_rank = IxFun.rank ixfun + ident_rank = shapeRank shape + unless (ixfun_rank == ident_rank) $ + TC.bad $ TC.TypeError $ + "Arity of index function (" ++ pretty ixfun_rank ++ + ") does not match rank of array " ++ pretty name ++ + " (" ++ show ident_rank ++ ")" + +bodyReturnsFromPattern :: PatternT (MemBound NoUniqueness) + -> ([(VName,BodyReturns)], [(VName,BodyReturns)]) +bodyReturnsFromPattern pat = + (map asReturns $ patternContextElements pat, + map asReturns $ patternValueElements pat) + where ctx = patternContextElements pat + + ext (Var v) + | Just (i, _) <- find ((==v) . patElemName . snd) $ zip [0..] ctx = + Ext i + ext se = Free se + + asReturns pe = + (patElemName pe, + case patElemDec pe of + MemPrim pt -> MemPrim pt + MemMem space -> MemMem space + MemArray pt shape u (ArrayIn mem ixfun) -> + MemArray pt (Shape $ map ext $ shapeDims shape) u $ + case find ((==mem) . patElemName . snd) $ zip [0..] ctx of + Just (i, PatElem _ (MemMem space)) -> + ReturnsNewBlock space i $ + existentialiseIxFun (map patElemName ctx) ixfun + _ -> ReturnsInBlock mem $ existentialiseIxFun [] ixfun + ) + +instance (PP.Pretty u, PP.Pretty r) => PrettyAnnot (PatElemT (MemInfo SubExp u r)) where + ppAnnot = bindeeAnnot patElemName patElemDec + +instance (PP.Pretty u, PP.Pretty r) => PrettyAnnot (Param (MemInfo SubExp u r)) where + ppAnnot = bindeeAnnot paramName paramDec + +bindeeAnnot :: (PP.Pretty u, PP.Pretty r) => + (a -> VName) -> (a -> MemInfo SubExp u r) + -> a -> Maybe PP.Doc +bindeeAnnot bindeeName bindeeLore bindee = + case bindeeLore bindee of + dec@MemArray{} -> + Just $ + PP.text "-- " <> + PP.oneLine (PP.ppr (bindeeName bindee) <> + PP.text " : " <> + PP.ppr dec) + MemMem {} -> + Nothing + MemPrim _ -> + Nothing + +extReturns :: [ExtType] -> [ExpReturns] +extReturns ts = + evalState (mapM addDec ts) 0 + where addDec (Prim bt) = + return $ MemPrim bt + addDec (Mem space) = + return $ MemMem space + addDec t@(Array bt shape u) + | existential t = do + i <- get <* modify (+1) + return $ MemArray bt shape u $ Just $ + ReturnsNewBlock DefaultSpace i $ + IxFun.iota $ map convert $ shapeDims shape + | otherwise = + return $ MemArray bt shape u Nothing + convert (Ext i) = LeafExp (Ext i) int32 + convert (Free v) = Free <$> primExpFromSubExp int32 v + +arrayVarReturns :: (HasScope lore m, Monad m, Mem lore) => + VName + -> m (PrimType, Shape, VName, IxFun.IxFun (PrimExp VName)) +arrayVarReturns v = do + summary <- lookupMemInfo v + case summary of + MemArray et shape _ (ArrayIn mem ixfun) -> + return (et, Shape $ shapeDims shape, mem, ixfun) + _ -> + error $ "arrayVarReturns: " ++ pretty v ++ " is not an array." + +varReturns :: (HasScope lore m, Monad m, Mem lore) => + VName -> m ExpReturns +varReturns v = do + summary <- lookupMemInfo v + case summary of + MemPrim bt -> + return $ MemPrim bt + MemArray et shape _ (ArrayIn mem ixfun) -> + return $ MemArray et (fmap Free shape) NoUniqueness $ + Just $ ReturnsInBlock mem $ existentialiseIxFun [] ixfun + MemMem space -> + return $ MemMem space + +-- | The return information of an expression. This can be seen as the +-- "return type with memory annotations" of the expression. +expReturns :: (Monad m, HasScope lore m, + Mem lore) => + Exp lore -> m [ExpReturns] + +expReturns (BasicOp (SubExp (Var v))) = + pure <$> varReturns v + +expReturns (BasicOp (Opaque (Var v))) = + pure <$> varReturns v + +expReturns (BasicOp (Repeat outer_shapes inner_shape v)) = do + t <- repeatDims outer_shapes inner_shape <$> lookupType v + (et, _, mem, ixfun) <- arrayVarReturns v + let outer_shapes' = map (map (primExpFromSubExp int32) . shapeDims) outer_shapes + inner_shape' = map (primExpFromSubExp int32) $ shapeDims inner_shape + return [MemArray et (Shape $ map Free $ arrayDims t) NoUniqueness $ + Just $ ReturnsInBlock mem $ existentialiseIxFun [] $ + IxFun.repeat ixfun outer_shapes' inner_shape'] + +expReturns (BasicOp (Reshape newshape v)) = do + (et, _, mem, ixfun) <- arrayVarReturns v + return [MemArray et (Shape $ map (Free . newDim) newshape) NoUniqueness $ + Just $ ReturnsInBlock mem $ existentialiseIxFun [] $ + IxFun.reshape ixfun $ map (fmap $ primExpFromSubExp int32) newshape] + +expReturns (BasicOp (Rearrange perm v)) = do + (et, Shape dims, mem, ixfun) <- arrayVarReturns v + let ixfun' = IxFun.permute ixfun perm + dims' = rearrangeShape perm dims + return [MemArray et (Shape $ map Free dims') NoUniqueness $ + Just $ ReturnsInBlock mem $ existentialiseIxFun [] ixfun'] + +expReturns (BasicOp (Rotate offsets v)) = do + (et, Shape dims, mem, ixfun) <- arrayVarReturns v + let offsets' = map (primExpFromSubExp int32) offsets + ixfun' = IxFun.rotate ixfun offsets' + return [MemArray et (Shape $ map Free dims) NoUniqueness $ + Just $ ReturnsInBlock mem $ existentialiseIxFun [] ixfun'] + +expReturns (BasicOp (Index v slice)) = do + info <- sliceInfo v slice + case info of + MemArray et shape u (ArrayIn mem ixfun) -> + return [MemArray et (fmap Free shape) u $ + Just $ ReturnsInBlock mem $ existentialiseIxFun [] ixfun] + MemPrim pt -> return [MemPrim pt] + MemMem space -> return [MemMem space] + +expReturns (BasicOp (Update v _ _)) = + pure <$> varReturns v + +expReturns (BasicOp op) = + extReturns . staticShapes <$> primOpType op + +expReturns e@(DoLoop ctx val _ _) = do + t <- expExtType e + zipWithM typeWithDec t $ map fst val + where typeWithDec t p = + case (t, paramDec p) of + (Array bt shape u, MemArray _ _ _ (ArrayIn mem ixfun)) + | Just (i, mem_p) <- isMergeVar mem, + Mem space <- paramType mem_p -> + return $ MemArray bt shape u $ Just $ ReturnsNewBlock space i ixfun' + | otherwise -> + return (MemArray bt shape u $ + Just $ ReturnsInBlock mem ixfun') + where ixfun' = existentialiseIxFun (map paramName mergevars) ixfun + (Array{}, _) -> + error "expReturns: Array return type but not array merge variable." + (Prim bt, _) -> + return $ MemPrim bt + (Mem{}, _) -> + error "expReturns: loop returns memory block explicitly." + isMergeVar v = find ((==v) . paramName . snd) $ zip [0..] mergevars + mergevars = map fst $ ctx ++ val + +expReturns (Apply _ _ ret _) = + return $ map funReturnsToExpReturns ret + +expReturns (If _ _ _ (IfDec ret _)) = + return $ map bodyReturnsToExpReturns ret + +expReturns (Op op) = + opReturns op + +sliceInfo :: (Monad m, HasScope lore m, Mem lore) => + VName + -> Slice SubExp -> m (MemInfo SubExp NoUniqueness MemBind) +sliceInfo v slice = do + (et, _, mem, ixfun) <- arrayVarReturns v + case sliceDims slice of + [] -> return $ MemPrim et + dims -> + return $ MemArray et (Shape dims) NoUniqueness $ + ArrayIn mem $ IxFun.slice ixfun + (map (fmap (primExpFromSubExp int32)) slice) + +class TypedOp (Op lore) => OpReturns lore where + opReturns :: (Monad m, HasScope lore m) => + Op lore -> m [ExpReturns] + opReturns op = extReturns <$> opType op + +applyFunReturns :: Typed dec => + [FunReturns] + -> [Param dec] + -> [(SubExp,Type)] + -> Maybe [FunReturns] +applyFunReturns rets params args + | Just _ <- applyRetType rettype params args = + Just $ map correctDims rets + | otherwise = + Nothing + where rettype = map declExtTypeOf rets + parammap :: M.Map VName (SubExp, Type) + parammap = M.fromList $ + zip (map paramName params) args + + substSubExp (Var v) + | Just (se,_) <- M.lookup v parammap = se + substSubExp se = se + + correctDims (MemPrim t) = + MemPrim t + correctDims (MemMem space) = + MemMem space + correctDims (MemArray et shape u memsummary) = + MemArray et (correctShape shape) u $ + correctSummary memsummary + + correctShape = Shape . map correctDim . shapeDims + correctDim (Ext i) = Ext i + correctDim (Free se) = Free $ substSubExp se + + correctSummary (ReturnsNewBlock space i ixfun) = + ReturnsNewBlock space i ixfun + correctSummary (ReturnsInBlock mem ixfun) = + -- FIXME: we should also do a replacement in ixfun here. + ReturnsInBlock mem' ixfun + where mem' = case M.lookup mem parammap of + Just (Var v, _) -> v + _ -> mem diff --git a/src/Futhark/IR/Mem/IxFun.hs b/src/Futhark/IR/Mem/IxFun.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/IR/Mem/IxFun.hs @@ -0,0 +1,849 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} +-- | This module contains a representation for the index function based on +-- linear-memory accessor descriptors; see Zhu, Hoeflinger and David work. +module Futhark.IR.Mem.IxFun + ( IxFun(..) + , index + , iota + , offsetIndex + , permute + , rotate + , reshape + , slice + , rebase + , repeat + , shape + , rank + , linearWithOffset + , rearrangeWithOffset + , isDirect + , isLinear + , substituteInIxFun + , leastGeneralGeneralization + , closeEnough + ) + where + +import Prelude hiding (mod, repeat) +import Data.List (sort, sortBy, zip4, zip5, zipWith5) +import qualified Data.List.NonEmpty as NE +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Function (on) +import Data.Maybe (isJust) +import Control.Monad.Identity +import Control.Monad.Writer +import qualified Data.Map.Strict as M + +import Futhark.Analysis.PrimExp (PrimExp(..)) +import Futhark.IR.Syntax.Core (Ext(..)) +import Futhark.Transform.Substitute +import Futhark.Transform.Rename +import Futhark.IR.Syntax + (ShapeChange, DimChange(..), DimIndex(..), Slice, unitSlice, dimFix) +import Futhark.IR.Prop +import Futhark.Util.IntegralExp +import Futhark.Util.Pretty +import Futhark.Analysis.PrimExp.Convert (substituteInPrimExp) +import qualified Futhark.Analysis.PrimExp.Generalize as PEG + +type Shape num = [num] +type Indices num = [num] +type Permutation = [Int] + +data Monotonicity = Inc | Dec | Unknown + -- ^ monotonously increasing, decreasing or unknown + deriving (Show, Eq) + +data LMADDim num = LMADDim { ldStride :: num + , ldRotate :: num + , ldShape :: num + , ldPerm :: Int + , ldMon :: Monotonicity + } + deriving (Show, Eq) + +-- | LMAD's representation consists of a general offset and for each dimension a +-- stride, rotate factor, number of elements (or shape), permutation, and +-- monotonicity. Note that the permutation is not strictly necessary in that the +-- permutation can be performed directly on LMAD dimensions, but then it is +-- difficult to extract the permutation back from an LMAD. +-- +-- LMAD algebra is closed under composition w.r.t. operators such as permute, +-- repeat, index and slice. However, other operations, such as reshape, cannot +-- always be represented inside the LMAD algebra. +-- +-- It follows that the general representation of an index function is a list of +-- LMADS, in which each following LMAD in the list implicitly corresponds to an +-- irregular reshaping operation. +-- +-- However, we expect that the common case is when the index function is one +-- LMAD -- we call this the "nice" representation. +-- +-- Finally, the list of LMADs is kept in an @IxFun@ together with the shape of +-- the original array, and a bit to indicate whether the index function is +-- contiguous, i.e., if we instantiate all the points of the current index +-- function, do we get a contiguous memory interval? +-- +-- By definition, the LMAD denotes the set of points (simplified): +-- +-- \{ o + \Sigma_{j=0}^{k} ((i_j+r_j) `mod` n_j)*s_j, +-- \forall i_j such that 0<=i_j Pretty (LMAD num) where + ppr (LMAD offset dims) = + braces $ semisep [ text "offset: " <> oneLine (ppr offset) + , text "strides: " <> p ldStride + , text "rotates: " <> p ldRotate + , text "shape: " <> p ldShape + , text "permutation: " <> p ldPerm + , text "monotonicity: " <> p ldMon + ] + where p f = oneLine $ brackets $ commasep $ map (ppr . f) dims + +instance Pretty num => Pretty (IxFun num) where + ppr (IxFun lmads oshp cg) = + braces $ semisep [ text "base: " <> brackets (commasep $ map ppr oshp) + , text "contiguous: " <> text (show cg) + , text "LMADs: " <> brackets (commasep $ NE.toList $ NE.map ppr lmads) + ] + + +instance Substitute num => Substitute (LMAD num) where + substituteNames substs = fmap $ substituteNames substs + +instance Substitute num => Substitute (IxFun num) where + substituteNames substs = fmap $ substituteNames substs + +instance Substitute num => Rename (LMAD num) where + rename = substituteRename + +instance Substitute num => Rename (IxFun num) where + rename = substituteRename + + +instance FreeIn num => FreeIn (LMAD num) where + freeIn' = foldMap freeIn' + +instance FreeIn num => FreeIn (IxFun num) where + freeIn' = foldMap freeIn' + +instance Functor LMAD where + fmap f = runIdentity . traverse (return . f) + +instance Functor IxFun where + fmap f = runIdentity . traverse (return . f) + + +instance Foldable LMAD where + foldMap f = execWriter . traverse (tell . f) + +instance Foldable IxFun where + foldMap f = execWriter . traverse (tell . f) + + +instance Traversable LMAD where + traverse f (LMAD offset dims) = + LMAD <$> f offset <*> traverse f' dims + where f' (LMADDim s r n p m) = + LMADDim <$> f s <*> f r <*> f n <*> pure p <*> pure m + +instance Traversable IxFun where + traverse f (IxFun lmads oshp cg) = + IxFun <$> traverse (traverse f) lmads <*> traverse f oshp <*> pure cg + +(++@) :: [a] -> NonEmpty a -> NonEmpty a +es ++@ (ne :| nes) = case es of + e : es' -> e :| es' ++ [ne] ++ nes + [] -> ne :| nes + +(@++@) :: NonEmpty a -> NonEmpty a -> NonEmpty a +(x :| xs) @++@ (y :| ys) = x :| xs ++ [y] ++ ys + +invertMonotonicity :: Monotonicity -> Monotonicity +invertMonotonicity Inc = Dec +invertMonotonicity Dec = Inc +invertMonotonicity Unknown = Unknown + +lmadPermutation :: LMAD num -> Permutation +lmadPermutation = map ldPerm . lmadDims + +setLMADPermutation :: Permutation -> LMAD num -> LMAD num +setLMADPermutation perm lmad = + lmad { lmadDims = zipWith (\dim p -> dim { ldPerm = p }) (lmadDims lmad) perm } + +setLMADShape :: Shape num -> LMAD num -> LMAD num +setLMADShape shp lmad = lmad { lmadDims = zipWith (\dim s -> dim { ldShape = s }) (lmadDims lmad) shp } + +-- | Substitute a name with a PrimExp in an LMAD. +substituteInLMAD :: Ord a => M.Map a (PrimExp a) -> LMAD (PrimExp a) + -> LMAD (PrimExp a) +substituteInLMAD tab (LMAD offset dims) = + let offset' = substituteInPrimExp tab offset + dims' = map (\(LMADDim s r n p m) -> + LMADDim + (substituteInPrimExp tab s) + (substituteInPrimExp tab r) + (substituteInPrimExp tab n) + p m) + dims + in LMAD offset' dims' + +-- | Substitute a name with a PrimExp in an index function. +substituteInIxFun :: (Ord a) => M.Map a (PrimExp a) -> IxFun (PrimExp a) + -> IxFun (PrimExp a) +substituteInIxFun tab (IxFun lmads oshp cg) = + IxFun (NE.map (substituteInLMAD tab) lmads) + (map (substituteInPrimExp tab) oshp) + cg + +-- | Is this is a row-major array? +isDirect :: (Eq num, IntegralExp num) => IxFun num -> Bool +isDirect ixfun@(IxFun (LMAD offset dims :| []) oshp True) = + let strides_expected = reverse $ scanl (*) 1 (reverse (tail oshp)) + in hasContiguousPerm ixfun && + length oshp == length dims && + offset == 0 && + all (\(LMADDim s r n p _, m, d, se) -> + s == se && r == 0 && n == d && p == m) + (zip4 dims [0..length dims - 1] oshp strides_expected) +isDirect _ = False + +-- | Does the index function have an ascending permutation? +hasContiguousPerm :: IxFun num -> Bool +hasContiguousPerm (IxFun (lmad :| []) _ _) = + let perm = lmadPermutation lmad + in perm == sort perm +hasContiguousPerm _ = False + +-- | Shape of an index function. +shape :: (Eq num, IntegralExp num) => IxFun num -> Shape num +shape (IxFun (lmad :| _) _ _) = lmadShape lmad + +-- | Shape of an LMAD. +lmadShape :: (Eq num, IntegralExp num) => LMAD num -> Shape num +lmadShape lmad = permuteInv (lmadPermutation lmad) $ lmadShapeBase lmad + +-- | Shape of an LMAD, ignoring permutations. +lmadShapeBase :: (Eq num, IntegralExp num) => LMAD num -> Shape num +lmadShapeBase = map ldShape . lmadDims + +-- | Compute the flat memory index for a complete set @inds@ of array indices +-- and a certain element size @elem_size@. +index :: (IntegralExp num, Eq num) => + IxFun num -> Indices num -> num +index = indexFromLMADs . ixfunLMADs + where indexFromLMADs :: (IntegralExp num, Eq num) => + NonEmpty (LMAD num) -> Indices num -> num + indexFromLMADs (lmad :| []) inds = indexLMAD lmad inds + indexFromLMADs (lmad1 :| lmad2 : lmads) inds = + let i_flat = indexLMAD lmad1 inds + new_inds = unflattenIndex (permuteFwd (lmadPermutation lmad2) $ lmadShapeBase lmad2) i_flat + in indexFromLMADs (lmad2 :| lmads) new_inds + + -- | Compute the flat index of an LMAD. + indexLMAD :: (IntegralExp num, Eq num) => + LMAD num -> Indices num -> num + indexLMAD lmad@(LMAD off dims) inds = + let prod = sum $ zipWith flatOneDim + (map (\(LMADDim s r n _ _) -> (s, r, n)) dims) + (permuteInv (lmadPermutation lmad) inds) + in off + prod + +-- | iota. +iota :: IntegralExp num => Shape num -> IxFun num +iota ns = + let rs = replicate (length ns) 0 + in IxFun (makeRotIota Inc 0 (zip rs ns) :| []) ns True + +-- | Permute dimensions. +permute :: IntegralExp num => + IxFun num -> Permutation -> IxFun num +permute (IxFun (lmad :| lmads) oshp cg) perm_new = + let perm_cur = lmadPermutation lmad + perm = map (perm_cur !!) perm_new + in IxFun (setLMADPermutation perm lmad :| lmads) oshp cg + +-- | Repeat dimensions. +repeat :: (Eq num, IntegralExp num) => + IxFun num -> [Shape num] -> Shape num -> IxFun num +repeat (IxFun (lmad@(LMAD off dims) :| lmads) oshp _) shps shp = + let perm = lmadPermutation lmad + -- inverse permute the shapes and update the permutation + lens = map (\s -> 1 + length s) shps + (shps', lens') = unzip $ permuteInv perm $ zip shps lens + scn = drop 1 $ scanl (+) 0 lens' + perm' = concatMap (\(p, l) -> map (\i-> (scn !! p) - l + i) [0..l-1]) + $ zip perm lens + tmp = length perm' + perm'' = perm' ++ [tmp..tmp-1+length shp] + + dims' = concatMap (\(shp_k, srnp) -> + map fakeDim shp_k ++ [srnp] + ) $ zip shps' dims + lmad' = setLMADPermutation perm'' $ LMAD off (dims' ++ map fakeDim shp) + in IxFun (lmad' :| lmads) oshp False -- XXX: Can we be less conservative? + where fakeDim x = LMADDim 0 0 x 0 Unknown + +-- | Rotate an index function. +rotate :: (Eq num, IntegralExp num) => + IxFun num -> Indices num -> IxFun num +rotate (IxFun (lmad@(LMAD off dims) :| lmads) oshp cg) offs = + let dims' = zipWith (\(LMADDim s r n p f) o -> + if s == 0 then LMADDim 0 0 n p Unknown + else LMADDim s (r + o) n p f + ) dims (permuteInv (lmadPermutation lmad) offs) + in IxFun (LMAD off dims' :| lmads) oshp cg + +-- | Handle the case where a slice can stay within a single LMAD. +sliceOneLMAD :: (Eq num, IntegralExp num) => + IxFun num -> Slice num -> Maybe (IxFun num) +sliceOneLMAD (IxFun (lmad@(LMAD _ ldims) :| lmads) oshp cg) is = do + let perm = lmadPermutation lmad + is' = permuteInv perm is + cg' = cg && slicePreservesContiguous lmad is' + guard $ harmlessRotation lmad is' + let lmad' = foldl sliceOne (LMAD (lmadOffset lmad) []) $ zip is' ldims + -- need to remove the fixed dims from the permutation + perm' = updatePerm perm $ map fst $ filter (isJust . dimFix . snd) $ + zip [0..length is' - 1] is' + + return $ IxFun (setLMADPermutation perm' lmad' :| lmads) oshp cg' + where updatePerm ps inds = foldl (\acc p -> acc ++ decrease p) [] ps + where decrease p = + let d = foldl (\n i -> if i == p then -1 + else if i > p + then n + else if n /= -1 then n + 1 + else n + ) 0 inds + in [p - d | d /= -1] + + harmlessRotation' :: (Eq num, IntegralExp num) => + LMADDim num -> DimIndex num -> Bool + harmlessRotation' _ (DimFix _) = True + harmlessRotation' (LMADDim 0 _ _ _ _) _ = True + harmlessRotation' (LMADDim _ 0 _ _ _) _ = True + harmlessRotation' (LMADDim _ _ n _ _) dslc + | dslc == DimSlice (n - 1) n (-1) || + dslc == unitSlice 0 n = True + harmlessRotation' _ _ = False + + harmlessRotation :: (Eq num, IntegralExp num) => + LMAD num -> Slice num -> Bool + harmlessRotation (LMAD _ dims) iss = + and $ zipWith harmlessRotation' dims iss + + -- XXX: TODO: what happens to r on a negative-stride slice; is there + -- such a case? + sliceOne :: (Eq num, IntegralExp num) => + LMAD num -> (DimIndex num, LMADDim num) -> LMAD num + sliceOne (LMAD off dims) (DimFix i, LMADDim s r n _ _) = + LMAD (off + flatOneDim (s, r, n) i) dims + sliceOne (LMAD off dims) (DimSlice _ ne _, LMADDim 0 _ _ p _) = + LMAD off (dims ++ [LMADDim 0 0 ne p Unknown]) + sliceOne (LMAD off dims) (dmind, dim@(LMADDim _ _ n _ _)) + | dmind == unitSlice 0 n = LMAD off (dims ++ [dim]) + sliceOne (LMAD off dims) (dmind, LMADDim s r n p m) + | dmind == DimSlice (n - 1) n (-1) = + let r' = if r == 0 then 0 else n - r + off' = off + flatOneDim (s, 0, n) (n - 1) + in LMAD off' (dims ++ [LMADDim (s * (-1)) r' n p (invertMonotonicity m)]) + sliceOne (LMAD off dims) (DimSlice b ne 0, LMADDim s r n p _) = + LMAD (off + flatOneDim (s, r, n) b) (dims ++ [LMADDim 0 0 ne p Unknown]) + sliceOne (LMAD off dims) (DimSlice bs ns ss, LMADDim s 0 _ p m) = + let m' = case sgn ss of + Just 1 -> m + Just (-1) -> invertMonotonicity m + _ -> Unknown + in LMAD (off + s * bs) (dims ++ [LMADDim (ss * s) 0 ns p m']) + sliceOne _ _ = error "slice: reached impossible case" + + slicePreservesContiguous :: (Eq num, IntegralExp num) => + LMAD num -> Slice num -> Bool + slicePreservesContiguous (LMAD _ dims) slc = + -- remove from the slice the LMAD dimensions that have stride 0. + -- If the LMAD was contiguous in mem, then these dims will not + -- influence the contiguousness of the result. + -- Also normalize the input slice, i.e., 0-stride and size-1 + -- slices are rewritten as DimFixed. + let (dims', slc') = unzip $ + filter ((/= 0) . ldStride . fst) $ + zip dims $ map normIndex slc + -- Check that: + -- 1. a clean split point exists between Fixed and Sliced dims + -- 2. the outermost sliced dim has +/- 1 stride AND is unrotated or full. + -- 3. the rest of inner sliced dims are full. + (_, success) = + foldl (\(found, res) (slcdim, LMADDim _ r n _ _) -> + case (slcdim, found) of + (DimFix{}, True ) -> (found, False) + (DimFix{}, False) -> (found, res) + (DimSlice _ ne ds, False) -> -- outermost sliced dim: +/-1 stride + let res' = (r == 0 || n == ne) && (ds == 1 || ds == -1) + in (True, res && res') + (DimSlice _ ne ds, True) -> -- inner sliced dim: needs to be full + let res' = (n == ne) && (ds == 1 || ds == -1) + in (found, res && res') + ) (False, True) $ zip slc' dims' + in success + + normIndex :: (Eq num, IntegralExp num) => + DimIndex num -> DimIndex num + normIndex (DimSlice b 1 _) = DimFix b + normIndex (DimSlice b _ 0) = DimFix b + normIndex d = d + +-- | Slice an index function. +slice :: (Eq num, IntegralExp num) => + IxFun num -> Slice num -> IxFun num +slice _ [] = error "slice: empty slice" +slice ixfun@(IxFun (lmad@(LMAD _ _) :| lmads) oshp cg) dim_slices + -- Avoid identity slicing. + | dim_slices == map (unitSlice 0) (shape ixfun) = ixfun + | Just ixfun' <- sliceOneLMAD ixfun dim_slices = ixfun' + | otherwise = + case sliceOneLMAD (iota (lmadShape lmad)) dim_slices of + Just (IxFun (lmad' :| []) _ cg') -> + IxFun (lmad' :| lmad : lmads) oshp (cg && cg') + _ -> error "slice: reached impossible case" + +-- | Handle the simple case where all reshape dimensions are coercions. +reshapeCoercion :: (Eq num, IntegralExp num) => + IxFun num -> ShapeChange num -> Maybe (IxFun num) +reshapeCoercion (IxFun (lmad@(LMAD off dims) :| lmads) _ cg) newshape = do + let perm = lmadPermutation lmad + (head_coercions, reshapes, tail_coercions) <- splitCoercions newshape + let hd_len = length head_coercions + num_coercions = hd_len + length tail_coercions + dims' = permuteFwd perm dims + mid_dims = take (length dims - num_coercions) $ drop hd_len dims' + num_rshps = length reshapes + guard (num_rshps == 0 || (num_rshps == 1 && length mid_dims == 1)) + let dims'' = map snd $ sortBy (compare `on` fst) $ + zipWith (\ld n -> (ldPerm ld, ld { ldShape = n })) + dims' (newDims newshape) + lmad' = LMAD off dims'' + return $ IxFun (lmad' :| lmads) (newDims newshape) cg + +-- | Handle the case where a reshape operation can stay inside a single LMAD. +-- +-- There are four conditions that all must hold for the result of a reshape +-- operation to remain in the one-LMAD domain: +-- +-- (1) the permutation of the underlying LMAD must leave unchanged +-- the LMAD dimensions that were *not* reshape coercions. +-- (2) the repetition of dimensions of the underlying LMAD must +-- refer only to the coerced-dimensions of the reshape operation. +-- (3) similarly, the rotated dimensions must refer only to +-- dimensions that are coerced by the reshape operation. +-- (4) finally, the underlying memory is contiguous (and monotonous). +-- +-- If any of these conditions do not hold, then the reshape operation will +-- conservatively add a new LMAD to the list, leading to a representation that +-- provides less opportunities for further analysis. +reshapeOneLMAD :: (Eq num, IntegralExp num) => + IxFun num -> ShapeChange num -> Maybe (IxFun num) +reshapeOneLMAD ixfun@(IxFun (lmad@(LMAD off dims) :| lmads) _ cg) newshape = do + let perm = lmadPermutation lmad + (head_coercions, reshapes, tail_coercions) <- splitCoercions newshape + let hd_len = length head_coercions + num_coercions = hd_len + length tail_coercions + dims_perm = permuteFwd perm dims + mid_dims = take (length dims - num_coercions) $ drop hd_len dims_perm + -- Ignore rotates, as we only care about not having rotates in the + -- dimensions that aren't coercions (@mid_dims@), which we check + -- separately. + mon = ixfunMonotonicityRots True ixfun + + guard $ + -- checking conditions (2) and (3) + all (\ (LMADDim s r _ _ _) -> s /= 0 && r == 0) mid_dims && + -- checking condition (1) + consecutive hd_len (map ldPerm mid_dims) && + -- checking condition (4) + hasContiguousPerm ixfun && cg && (mon == Inc || mon == Dec) + + -- make new permutation + let rsh_len = length reshapes + diff = length newshape - length dims + iota_shape = [0..length newshape-1] + perm' = map (\i -> let ind = if i < hd_len + then i else i - diff + in if (i >= hd_len) && (i < hd_len + rsh_len) + then i -- already checked mid_dims not affected + else let p = ldPerm (dims !! ind) + in if p < hd_len + then p + else p + diff + ) iota_shape + -- split the dimensions + (support_inds, repeat_inds) = + foldl (\(sup, rpt) (i, shpdim, ip) -> + case (i < hd_len, i >= hd_len + rsh_len, shpdim) of + (True, _, DimCoercion n) -> + case dims_perm !! i of + (LMADDim 0 _ _ _ _) -> ( sup, (ip, n) : rpt ) + (LMADDim _ r _ _ _) -> ( (ip, (r, n)) : sup, rpt ) + (_, True, DimCoercion n) -> + case dims_perm !! (i-diff) of + (LMADDim 0 _ _ _ _) -> ( sup, (ip, n) : rpt ) + (LMADDim _ r _ _ _) -> ( (ip, (r, n)) : sup, rpt ) + (False, False, _) -> + ( (ip, (0, newDim shpdim)) : sup, rpt ) + -- already checked that the reshaped + -- dims cannot be repeats or rotates + _ -> error "reshape: reached impossible case" + ) ([], []) $ reverse $ zip3 iota_shape newshape perm' + + (sup_inds, support) = unzip $ sortBy (compare `on` fst) support_inds + (rpt_inds, repeats) = unzip repeat_inds + LMAD off' dims_sup = makeRotIota mon off support + repeats' = map (\n -> LMADDim 0 0 n 0 Unknown) repeats + dims' = map snd $ sortBy (compare `on` fst) + $ zip sup_inds dims_sup ++ zip rpt_inds repeats' + lmad' = LMAD off' dims' + return $ IxFun (setLMADPermutation perm' lmad' :| lmads) (newDims newshape) cg + where consecutive _ [] = True + consecutive i [p]= i == p + consecutive i ps = and $ zipWith (==) ps [i, i+1..] + +splitCoercions :: (Eq num, IntegralExp num) => + ShapeChange num -> Maybe (ShapeChange num, ShapeChange num, ShapeChange num) +splitCoercions newshape' = do + let (head_coercions, newshape'') = span isCoercion newshape' + (reshapes, tail_coercions) = break isCoercion newshape'' + guard (all isCoercion tail_coercions) + return (head_coercions, reshapes, tail_coercions) + where isCoercion DimCoercion{} = True + isCoercion _ = False + +-- | Reshape an index function. +reshape :: (Eq num, IntegralExp num) => + IxFun num -> ShapeChange num -> IxFun num +reshape ixfun new_shape + | Just ixfun' <- reshapeCoercion ixfun new_shape = ixfun' + | Just ixfun' <- reshapeOneLMAD ixfun new_shape = ixfun' +reshape (IxFun (lmad0 :| lmad0s) oshp cg) new_shape = + case iota (newDims new_shape) of + IxFun (lmad :| []) _ _ -> IxFun (lmad :| lmad0 : lmad0s) oshp cg + _ -> error "reshape: reached impossible case" + +-- | The number of dimensions in the domain of the input function. +rank :: IntegralExp num => + IxFun num -> Int +rank (IxFun (LMAD _ sss :| _) _ _) = length sss + +-- | Handle the case where a rebase operation can stay within m + n - 1 LMADs, +-- where m is the number of LMADs in the index function, and n is the number of +-- LMADs in the new base. If both index function have only on LMAD, this means +-- that we stay within the single-LMAD domain. +-- +-- We can often stay in that domain if the original ixfun is essentially a +-- slice, e.g. `x[i, (k1,m,s1), (k2,n,s2)] = orig`. +-- +-- XXX: TODO: handle repetitions in both lmads. +-- +-- How to handle repeated dimensions in the original? +-- +-- (a) Shave them off of the last lmad of original +-- (b) Compose the result from (a) with the first +-- lmad of the new base +-- (c) apply a repeat operation on the result of (b). +-- +-- However, I strongly suspect that for in-place update what we need is actually +-- the INVERSE of the rebase function, i.e., given an index function new-base +-- and another one orig, compute the index function ixfun0 such that: +-- +-- new-base == rebase ixfun0 ixfun, or equivalently: +-- new-base == ixfun o ixfun0 +-- +-- because then I can go bottom up and compose with ixfun0 all the index +-- functions corresponding to the memory block associated with ixfun. +rebaseNice :: (Eq num, IntegralExp num) => + IxFun num -> IxFun num -> Maybe (IxFun num) +rebaseNice + new_base@(IxFun (lmad_base :| lmads_base) _ cg_base) + ixfun@(IxFun lmads shp cg) = do + let (lmad_full :| lmads') = NE.reverse lmads + ((outer_shapes, inner_shape), lmad) = shaveoffRepeats lmad_full + dims = lmadDims lmad + perm = lmadPermutation lmad + perm_base = lmadPermutation lmad_base + + guard $ + -- Core rebase condition. + base ixfun == shape new_base + -- Conservative safety conditions: ixfun is contiguous and has known + -- monotonicity for all dimensions. + && cg && all ((/= Unknown) . ldMon) dims + -- XXX: We should be able to handle some basic cases where both index + -- functions have non-trivial permutations. + && (hasContiguousPerm ixfun || hasContiguousPerm new_base) + -- We need the permutations to be of the same size if we want to compose + -- them. They don't have to be of the same size if the ixfun has a trivial + -- permutation. Supporting this latter case allows us to rebase when ixfun + -- has been created by slicing with fixed dimensions. + && (length perm == length perm_base || hasContiguousPerm ixfun) + -- To not have to worry about ixfun having non-1 strides, we also check that + -- it is a row-major array (modulo permutation, which is handled + -- separately). Accept a non-full innermost dimension. XXX: Maybe this can + -- be less conservative? + && and (zipWith3 (\sn ld inner -> sn == ldShape ld || (inner && ldStride ld == 1)) + shp dims (replicate (length dims - 1) False ++ [True])) + + -- Compose permutations, reverse strides and adjust offset if necessary. + let perm_base' = if hasContiguousPerm ixfun + then perm_base + else map (perm !!) perm_base + lmad_base' = setLMADPermutation perm_base' lmad_base + dims_base = lmadDims lmad_base' + n_fewer_dims = length dims_base - length dims + (dims_base', offs_contrib) = unzip $ + zipWith (\(LMADDim s1 r1 n1 p1 _) (LMADDim _ r2 _ _ m2) -> + let (s', off') | m2 == Inc = (s1, 0) + | otherwise = (s1 * (-1), s1 * (n1 - 1)) + r' | m2 == Inc = if r2 == 0 then r1 else r1 + r2 + | r1 == 0 = r2 + | r2 == 0 = n1 - r1 + | otherwise = n1 - r1 + r2 + in (LMADDim s' r' n1 (p1 - n_fewer_dims) Inc, off')) + -- If @dims@ is morally a slice, it might have fewer dimensions than + -- @dims_base@. Drop extraneous outer dimensions. + (drop n_fewer_dims dims_base) dims + off_base = lmadOffset lmad_base' + sum offs_contrib + lmad_base'' + | lmadOffset lmad == 0 = LMAD off_base dims_base' + | otherwise = + -- If the innermost dimension of the ixfun was not full (but still + -- had a stride of 1), add its offset relative to the new base. + setLMADShape (lmadShape lmad) + (LMAD (off_base + ldStride (last dims_base) * lmadOffset lmad) + dims_base') + new_base' = IxFun (lmad_base'' :| lmads_base) shp cg_base + IxFun lmads_base' _ _ = if all null outer_shapes && null inner_shape + then new_base' + else repeat new_base' outer_shapes inner_shape + lmads'' = lmads' ++@ lmads_base' + return $ IxFun lmads'' shp (cg && cg_base) + where shaveoffRepeats :: (Eq num, IntegralExp num) => + LMAD num -> (([Shape num], Shape num), LMAD num) + shaveoffRepeats lmad = + -- Given an input lmad, this function computes a repetition @r@ and a new lmad + -- @res@, such that @repeat r res@ is identical to the input lmad. + let perm = lmadPermutation lmad + dims = lmadDims lmad + -- compute the Repeat: + resacc= foldl (\acc (LMADDim s _ n _ _) -> + case acc of + rpt : acc0 -> + if s == 0 then (n : rpt) : acc0 + else [] : (rpt : acc0) + _ -> error "shaveoffRepeats: empty accumulator" + ) [[]] $ reverse $ permuteFwd perm dims + last_shape = last resacc + shapes = take (length resacc - 1) resacc + -- update permutation and lmad: + howManyRepLT k = + foldl (\i (LMADDim s _ _ p _) -> + if s == 0 && p < k then i + 1 else i + ) 0 dims + dims' = foldl (\acc (LMADDim s r n p info) -> + if s == 0 then acc + else let p' = p - howManyRepLT p + in LMADDim s r n p' info : acc + ) [] $ reverse dims + lmad' = LMAD (lmadOffset lmad) dims' + in ((shapes, last_shape), lmad') + +-- | Rebase an index function on top of a new base. +rebase :: (Eq num, IntegralExp num) => + IxFun num -> IxFun num -> IxFun num +rebase new_base@(IxFun lmads_base shp_base cg_base) ixfun@(IxFun lmads shp cg) + | Just ixfun' <- rebaseNice new_base ixfun = ixfun' + -- In the general case just concatenate LMADs since this refers to index + -- function composition, which is always safe. + | otherwise = + let (lmads_base', shp_base') = + if base ixfun == shape new_base + then (lmads_base, shp_base) + else let IxFun lmads' shp_base'' _ = reshape new_base $ map DimCoercion shp + in (lmads', shp_base'') + in IxFun (lmads @++@ lmads_base') shp_base' (cg && cg_base) + +ixfunMonotonicity :: (Eq num, IntegralExp num) => IxFun num -> Monotonicity +ixfunMonotonicity = ixfunMonotonicityRots False + +-- | Offset index. Results in the index function corresponding to indexing with +-- @i@ on the outermost dimension. +offsetIndex :: (Eq num, IntegralExp num) => + IxFun num -> num -> IxFun num +offsetIndex ixfun i | i == 0 = ixfun +offsetIndex ixfun i = + case shape ixfun of + d : ds -> slice ixfun (DimSlice i (d - i) 1 : map (unitSlice 0) ds) + [] -> error "offsetIndex: underlying index function has rank zero" + +-- | If the memory support of the index function is contiguous and row-major +-- (i.e., no transpositions, repetitions, rotates, etc.), then this should +-- return the offset from which the memory-support of this index function +-- starts. +linearWithOffset :: (Eq num, IntegralExp num) => + IxFun num -> num -> Maybe num +linearWithOffset ixfun@(IxFun (lmad :| []) _ cg) elem_size + | hasContiguousPerm ixfun && cg && ixfunMonotonicity ixfun == Inc = + Just $ lmadOffset lmad * elem_size +linearWithOffset _ _ = Nothing + +-- | Similar restrictions to @linearWithOffset@ except for transpositions, which +-- are returned together with the offset. +rearrangeWithOffset :: (Eq num, IntegralExp num) => + IxFun num -> num -> Maybe (num, [(Int,num)]) +rearrangeWithOffset (IxFun (lmad :| []) oshp cg) elem_size = do + -- Note that @cg@ describes whether the index function is + -- contiguous, *ignoring permutations*. This function requires that + -- functionality. + let perm = lmadPermutation lmad + perm_contig = [0..length perm-1] + offset <- linearWithOffset + (IxFun (setLMADPermutation perm_contig lmad :| []) oshp cg) elem_size + return (offset, zip perm (permuteFwd perm (lmadShapeBase lmad))) +rearrangeWithOffset _ _ = Nothing + +-- | Is this a row-major array starting at offset zero? +isLinear :: (Eq num, IntegralExp num) => IxFun num -> Bool +isLinear = (== Just 0) . flip linearWithOffset 1 + +permuteFwd :: Permutation -> [a] -> [a] +permuteFwd ps elems = map (elems !!) ps + +permuteInv :: Permutation -> [a] -> [a] +permuteInv ps elems = map snd $ sortBy (compare `on` fst) $ zip ps elems + +flatOneDim :: (Eq num, IntegralExp num) => + (num, num, num) -> num -> num +flatOneDim (s, r, n) i + | s == 0 = 0 + | r == 0 = i * s + | otherwise = ((i + r) `mod` n) * s + +-- | Generalised iota with user-specified offset and strides. +makeRotIota :: IntegralExp num => + Monotonicity -> num -> [(num, num)] -> LMAD num +makeRotIota mon off support + | mon == Inc || mon == Dec = + let rk = length support + (rs, ns) = unzip support + ss0 = reverse $ take rk $ scanl (*) 1 $ reverse ns + ss = if mon == Inc + then ss0 + else map (* (-1)) ss0 + ps = map fromIntegral [0..rk-1] + fi = replicate rk mon + in LMAD off $ zipWith5 LMADDim ss rs ns ps fi + | otherwise = error "makeRotIota: requires Inc or Dec" + +-- | Check monotonicity of an index function. +ixfunMonotonicityRots :: (Eq num, IntegralExp num) => + Bool -> IxFun num -> Monotonicity +ixfunMonotonicityRots ignore_rots (IxFun (lmad :| lmads) _ _) = + let mon0 = lmadMonotonicityRots lmad + in if all ((== mon0) . lmadMonotonicityRots) lmads + then mon0 + else Unknown + where lmadMonotonicityRots :: (Eq num, IntegralExp num) => + LMAD num -> Monotonicity + lmadMonotonicityRots (LMAD _ dims) + | all (isMonDim Inc) dims = Inc + | all (isMonDim Dec) dims = Dec + | otherwise = Unknown + + isMonDim :: (Eq num, IntegralExp num) => + Monotonicity -> LMADDim num -> Bool + isMonDim mon (LMADDim s r _ _ ldmon) = + s == 0 || ((ignore_rots || r == 0) && mon == ldmon) + +-- | Generalization (anti-unification) +-- +-- Anti-unification of two index functions is supported under the following conditions: +-- 0. Both index functions are represented by ONE lmad (assumed common case!) +-- 1. The support array of the two indexfuns have the same dimensionality +-- (we can relax this condition if we use a 1D support, as we probably should!) +-- 2. The contiguous property and the per-dimension monotonicity are the same +-- (otherwise we might loose important information; this can be relaxed!) +-- 3. Most importantly, both index functions correspond to the same permutation +-- (since the permutation is represented by INTs, this restriction cannot +-- be relaxed, unless we move to a gated-LMAD representation!) +leastGeneralGeneralization :: Eq v => IxFun (PrimExp v) -> IxFun (PrimExp v) -> + Maybe (IxFun (PrimExp (Ext v)), [(PrimExp v, PrimExp v)]) +leastGeneralGeneralization (IxFun (lmad1 :| []) oshp1 ctg1) (IxFun (lmad2 :| []) oshp2 ctg2) = do + guard $ + length oshp1 == length oshp2 && + ctg1 == ctg2 && + map ldPerm (lmadDims lmad1) == map ldPerm (lmadDims lmad2) && + lmadDMon lmad1 == lmadDMon lmad2 + let (ctg, dperm, dmon) = (ctg1, lmadPermutation lmad1, lmadDMon lmad1) + (dshp, m1) <- generalize [] (lmadDShp lmad1) (lmadDShp lmad2) + (oshp, m2) <- generalize m1 oshp1 oshp2 + (dstd, m3) <- generalize m2 (lmadDSrd lmad1) (lmadDSrd lmad2) + (drot, m4) <- generalize m3 (lmadDRot lmad1) (lmadDRot lmad2) + (offt, m5) <- PEG.leastGeneralGeneralization m4 (lmadOffset lmad1) (lmadOffset lmad2) + let lmad_dims = map (\(a,b,c,d,e) -> LMADDim a b c d e) $ + zip5 dstd drot dshp dperm dmon + lmad = LMAD offt lmad_dims + return (IxFun (lmad :| []) oshp ctg, m5) + where lmadDMon = map ldMon . lmadDims + lmadDSrd = map ldStride . lmadDims + lmadDShp = map ldShape . lmadDims + lmadDRot = map ldRotate . lmadDims + generalize m l1 l2 = + foldM (\(l_acc, m') (pe1,pe2) -> do + (e, m'') <- PEG.leastGeneralGeneralization m' pe1 pe2 + return (l_acc++[e], m'') + ) ([], m) (zip l1 l2) +leastGeneralGeneralization _ _ = Nothing + +-- | When comparing index functions as part of the type check in KernelsMem, +-- we may run into problems caused by the simplifier. As index functions can be +-- generalized over if-then-else expressions, the simplifier might hoist some of +-- the code from inside the if-then-else (computing the offset of an array, for +-- instance), but now the type checker cannot verify that the generalized index +-- function is valid, because some of the existentials are computed somewhere +-- else. To Work around this, we've had to relax the KernelsMem type-checker +-- a bit, specifically, we've introduced this function to verify whether two +-- index functions are "close enough" that we can assume that they match. We use +-- this instead of `ixfun1 == ixfun2` and hope that it's good enough. +closeEnough :: IxFun num -> IxFun num -> Bool +closeEnough ixf1 ixf2 = + (length (base ixf1) == length (base ixf2)) && + (ixfunContig ixf1 == ixfunContig ixf2) && + (NE.length (ixfunLMADs ixf1) == NE.length (ixfunLMADs ixf2)) && + all closeEnoughLMADs (NE.zip (ixfunLMADs ixf1) (ixfunLMADs ixf2)) + where + closeEnoughLMADs :: (LMAD num, LMAD num) -> Bool + closeEnoughLMADs (lmad1, lmad2) = + length (lmadDims lmad1) == length (lmadDims lmad2) && + map ldPerm (lmadDims lmad1) == + map ldPerm (lmadDims lmad2) diff --git a/src/Futhark/IR/Mem/Simplify.hs b/src/Futhark/IR/Mem/Simplify.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/IR/Mem/Simplify.hs @@ -0,0 +1,216 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ConstraintKinds #-} +module Futhark.IR.Mem.Simplify + ( simplifyProgGeneric + , simplifyStmsGeneric + , simpleGeneric + , SimplifyMemory + ) +where + +import Control.Monad +import Data.List (find) + +import qualified Futhark.IR.Syntax as AST +import Futhark.IR.Syntax + hiding (Prog, BasicOp, Exp, Body, Stm, + Pattern, PatElem, Lambda, FunDef, FParam, LParam, RetType) +import Futhark.IR.Mem +import qualified Futhark.IR.Mem.IxFun as IxFun +import Futhark.Pass.ExplicitAllocations (simplifiable) +import qualified Futhark.Analysis.SymbolTable as ST +import qualified Futhark.Analysis.UsageTable as UT +import qualified Futhark.Optimise.Simplify.Engine as Engine +import qualified Futhark.Optimise.Simplify as Simplify +import Futhark.Construct +import Futhark.Pass +import Futhark.Optimise.Simplify.Rules +import Futhark.Optimise.Simplify.Rule +import Futhark.Optimise.Simplify.Lore +import Futhark.Util + +simpleGeneric :: (SimplifyMemory lore, Op lore ~ MemOp inner) => + Simplify.SimplifyOp lore inner + -> Simplify.SimpleOps lore +simpleGeneric = simplifiable + +simplifyProgGeneric :: (SimplifyMemory lore, + Op lore ~ MemOp inner) => + Simplify.SimplifyOp lore inner + -> Prog lore -> PassM (Prog lore) +simplifyProgGeneric onInner = + Simplify.simplifyProg (simpleGeneric onInner) callKernelRules + blockers { Engine.blockHoistBranch = blockAllocs } + where blockAllocs vtable _ (Let _ _ (Op Alloc{})) = + not $ ST.simplifyMemory vtable + -- Do not hoist statements that produce arrays. This is + -- because in the KernelsMem representation, multiple + -- arrays can be located in the same memory block, and moving + -- their creation out of a branch can thus cause memory + -- corruption. At this point in the compiler we have probably + -- already moved all the array creations that matter. + blockAllocs _ _ (Let pat _ _) = + not $ all primType $ patternTypes pat + +simplifyStmsGeneric :: (HasScope lore m, MonadFreshNames m, + SimplifyMemory lore, Op lore ~ MemOp inner) => + Simplify.SimplifyOp lore inner -> Stms lore + -> m (ST.SymbolTable (Wise lore), Stms lore) +simplifyStmsGeneric onInner stms = do + scope <- askScope + Simplify.simplifyStms (simpleGeneric onInner) callKernelRules blockers + scope stms + +isResultAlloc :: Op lore ~ MemOp op => Engine.BlockPred lore +isResultAlloc _ usage (Let (AST.Pattern [] [bindee]) _ (Op Alloc{})) = + UT.isInResult (patElemName bindee) usage +isResultAlloc _ _ _ = False + +-- | Getting the roots of what to hoist, for now only variable +-- names that represent array and memory-block sizes. +getShapeNames :: (Mem lore, Op lore ~ MemOp op) => + Stm (Wise lore) -> Names +getShapeNames stm = + let ts = map patElemType $ patternElements $ stmPattern stm + in freeIn (concatMap arrayDims ts) <> + case stmExp stm of Op (Alloc size _) -> freeIn size + _ -> mempty + +isAlloc :: Op lore ~ MemOp op => Engine.BlockPred lore +isAlloc _ _ (Let _ _ (Op Alloc{})) = True +isAlloc _ _ _ = False + +blockers :: (Mem lore, Op lore ~ MemOp inner) => + Simplify.HoistBlockers lore +blockers = Engine.noExtraHoistBlockers { + Engine.blockHoistPar = isAlloc + , Engine.blockHoistSeq = isResultAlloc + , Engine.getArraySizes = getShapeNames + , Engine.isAllocation = isAlloc mempty mempty + } + +-- | Some constraints that must hold for the simplification rules to work. +type SimplifyMemory lore = + (Simplify.SimplifiableLore lore, + ExpDec lore ~ (), + BodyDec lore ~ (), + AllocOp (Op (Wise lore)), + CanBeWise (Op lore), + BinderOps (Wise lore), + Mem lore) + +callKernelRules :: SimplifyMemory lore => RuleBook (Wise lore) +callKernelRules = standardRules <> + ruleBook [RuleBasicOp copyCopyToCopy, + RuleBasicOp removeIdentityCopy, + RuleIf unExistentialiseMemory] [] + +-- | If a branch is returning some existential memory, but the size of +-- the array is not existential, then we can create a block of the +-- proper size and always return there. +unExistentialiseMemory :: SimplifyMemory lore => TopDownRuleIf (Wise lore) +unExistentialiseMemory vtable pat _ (cond, tbranch, fbranch, ifdec) + | ST.simplifyMemory vtable, + fixable <- foldl hasConcretisableMemory mempty $ patternElements pat, + not $ null fixable = Simplify $ do + + -- Create non-existential memory blocks big enough to hold the + -- arrays. + (arr_to_mem, oldmem_to_mem) <- + fmap unzip $ forM fixable $ \(arr_pe, mem_size, oldmem, space) -> do + size <- toSubExp "size" mem_size + mem <- letExp "mem" $ Op $ allocOp size space + return ((patElemName arr_pe, mem), (oldmem, mem)) + + -- Update the branches to contain Copy expressions putting the + -- arrays where they are expected. + let updateBody body = insertStmsM $ do + res <- bodyBind body + resultBodyM =<< + zipWithM updateResult (patternElements pat) res + updateResult pat_elem (Var v) + | Just mem <- lookup (patElemName pat_elem) arr_to_mem, + (_, MemArray pt shape u (ArrayIn _ ixfun)) <- patElemDec pat_elem = do + v_copy <- newVName $ baseString v <> "_nonext_copy" + let v_pat = Pattern [] [PatElem v_copy $ + MemArray pt shape u $ ArrayIn mem ixfun] + addStm $ mkWiseLetStm v_pat (defAux ()) $ BasicOp (Copy v) + return $ Var v_copy + | Just mem <- lookup (patElemName pat_elem) oldmem_to_mem = + return $ Var mem + updateResult _ se = + return se + tbranch' <- updateBody tbranch + fbranch' <- updateBody fbranch + letBind pat $ If cond tbranch' fbranch' ifdec + where onlyUsedIn name here = not $ any ((name `nameIn`) . freeIn) $ + filter ((/=here) . patElemName) $ + patternValueElements pat + knownSize Constant{} = True + knownSize (Var v) = not $ inContext v + inContext = (`elem` patternContextNames pat) + + hasConcretisableMemory fixable pat_elem + | (_, MemArray pt shape _ (ArrayIn mem ixfun)) <- patElemDec pat_elem, + Just (j, Mem space) <- + fmap patElemType <$> find ((mem==) . patElemName . snd) + (zip [(0::Int)..] $ patternElements pat), + Just tse <- maybeNth j $ bodyResult tbranch, + Just fse <- maybeNth j $ bodyResult fbranch, + mem `onlyUsedIn` patElemName pat_elem, + all knownSize (shapeDims shape), + fse /= tse = + let mem_size = + ConvOpExp (SExt Int32 Int64) $ + product $ primByteSize pt : IxFun.base ixfun + in (pat_elem, mem_size, mem, space) : fixable + | otherwise = + fixable +unExistentialiseMemory _ _ _ _ = Skip + +-- | If we are copying something that is itself a copy, just copy the +-- original one instead. +copyCopyToCopy :: (BinderOps lore, + LetDec lore ~ (VarWisdom, MemBound u)) => + TopDownRuleBasicOp lore +copyCopyToCopy vtable pat@(Pattern [] [pat_elem]) _ (Copy v1) + | Just (BasicOp (Copy v2), v1_cs) <- ST.lookupExp v1 vtable, + + Just (_, MemArray _ _ _ (ArrayIn srcmem src_ixfun)) <- + ST.entryLetBoundDec =<< ST.lookup v1 vtable, + + Just (Mem src_space) <- ST.lookupType srcmem vtable, + + (_, MemArray _ _ _ (ArrayIn destmem dest_ixfun)) <- patElemDec pat_elem, + + Just (Mem dest_space) <- ST.lookupType destmem vtable, + + src_space == dest_space, dest_ixfun == src_ixfun = + + Simplify $ certifying v1_cs $ letBind pat $ BasicOp $ Copy v2 + +copyCopyToCopy vtable pat _ (Copy v0) + | Just (BasicOp (Rearrange perm v1), v0_cs) <- ST.lookupExp v0 vtable, + Just (BasicOp (Copy v2), v1_cs) <- ST.lookupExp v1 vtable = Simplify $ do + v0' <- certifying (v0_cs<>v1_cs) $ + letExp "rearrange_v0" $ BasicOp $ Rearrange perm v2 + letBind pat $ BasicOp $ Copy v0' + +copyCopyToCopy _ _ _ _ = Skip + +-- | If the destination of a copy is the same as the source, just +-- remove it. +removeIdentityCopy :: (BinderOps lore, + LetDec lore ~ (VarWisdom, MemBound u)) => + TopDownRuleBasicOp lore +removeIdentityCopy vtable pat@(Pattern [] [pe]) _ (Copy v) + | (_, MemArray _ _ _ (ArrayIn dest_mem dest_ixfun)) <- patElemDec pe, + Just (_, MemArray _ _ _ (ArrayIn src_mem src_ixfun)) <- + ST.entryLetBoundDec =<< ST.lookup v vtable, + dest_mem == src_mem, dest_ixfun == src_ixfun = + Simplify $ letBind pat $ BasicOp $ SubExp $ Var v + +removeIdentityCopy _ _ _ _ = Skip diff --git a/src/Futhark/IR/Pretty.hs b/src/Futhark/IR/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/IR/Pretty.hs @@ -0,0 +1,295 @@ +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +-- | Futhark prettyprinter. This module defines 'Pretty' instances +-- for the AST defined in "Futhark.IR.Syntax", +-- but also a number of convenience functions if you don't want to use +-- the interface from 'Pretty'. +module Futhark.IR.Pretty + ( prettyTuple + , pretty + , PrettyAnnot (..) + , PrettyLore (..) + , ppTuple' + ) + where + +import Data.Foldable (toList) +import Data.Maybe + +import Futhark.Util.Pretty +import Futhark.IR.Prop.Patterns +import Futhark.IR.Syntax + +-- | Class for values that may have some prettyprinted annotation. +class PrettyAnnot a where + ppAnnot :: a -> Maybe Doc + +instance PrettyAnnot (PatElemT (TypeBase shape u)) where + ppAnnot = const Nothing + +instance PrettyAnnot (Param (TypeBase shape u)) where + ppAnnot = const Nothing + +instance PrettyAnnot () where + ppAnnot = const Nothing + +-- | The class of lores whose annotations can be prettyprinted. +class (Decorations lore, + Pretty (RetType lore), + Pretty (BranchType lore), + Pretty (Param (FParamInfo lore)), + Pretty (Param (LParamInfo lore)), + Pretty (PatElemT (LetDec lore)), + PrettyAnnot (PatElem lore), + PrettyAnnot (FParam lore), + PrettyAnnot (LParam lore), + Pretty (Op lore)) => PrettyLore lore where + ppExpLore :: ExpDec lore -> Exp lore -> Maybe Doc + ppExpLore _ (If _ _ _ (IfDec ts _)) = + Just $ stack $ map (text . ("-- "++)) $ lines $ pretty $ + text "Branch returns:" <+> ppTuple' ts + ppExpLore _ _ = Nothing + +commastack :: [Doc] -> Doc +commastack = align . stack . punctuate comma + +instance Pretty VName where + ppr (VName vn i) = ppr vn <> text "_" <> text (show i) + +instance Pretty NoUniqueness where + ppr _ = mempty + +instance Pretty Commutativity where + ppr Commutative = text "commutative" + ppr Noncommutative = text "noncommutative" + +instance Pretty Shape where + ppr = brackets . commasep . map ppr . shapeDims + +instance Pretty a => Pretty (Ext a) where + ppr (Free e) = ppr e + ppr (Ext x) = text "?" <> text (show x) + +instance Pretty ExtShape where + ppr = brackets . commasep . map ppr . shapeDims + +instance Pretty Space where + ppr DefaultSpace = mempty + ppr (Space s) = text "@" <> text s + ppr (ScalarSpace d t) = text "@" <> mconcat (map (brackets . ppr) d) <> ppr t + +instance Pretty u => Pretty (TypeBase Shape u) where + ppr (Prim et) = ppr et + ppr (Array et (Shape ds) u) = + ppr u <> mconcat (map (brackets . ppr) ds) <> ppr et + ppr (Mem s) = text "mem" <> ppr s + +instance Pretty u => Pretty (TypeBase ExtShape u) where + ppr (Prim et) = ppr et + ppr (Array et (Shape ds) u) = + ppr u <> mconcat (map (brackets . ppr) ds) <> ppr et + ppr (Mem s) = text "mem" <> ppr s + +instance Pretty u => Pretty (TypeBase Rank u) where + ppr (Prim et) = ppr et + ppr (Array et (Rank n) u) = + ppr u <> mconcat (replicate n $ brackets mempty) <> ppr et + ppr (Mem s) = text "mem" <> ppr s + +instance Pretty Ident where + ppr ident = ppr (identType ident) <+> ppr (identName ident) + +instance Pretty SubExp where + ppr (Var v) = ppr v + ppr (Constant v) = ppr v + +instance Pretty Certificates where + ppr (Certificates []) = empty + ppr (Certificates cs) = text "<" <> commasep (map ppr cs) <> text ">" + +instance PrettyLore lore => Pretty (Stms lore) where + ppr = stack . map ppr . stmsToList + +instance PrettyLore lore => Pretty (Body lore) where + ppr (Body _ stms res) + | null stms = braces (commasep $ map ppr res) + | otherwise = stack (map ppr $ stmsToList stms) + text "in" <+> braces (commasep $ map ppr res) + +instance Pretty Attr where + ppr (AttrAtom v) = ppr v + +attrAnnots :: Stm lore -> [Doc] +attrAnnots = map f . toList . unAttrs . stmAuxAttrs . stmAux + where f v = text "#[" <> ppr v <> text "]" + +instance Pretty (PatElemT dec) => Pretty (PatternT dec) where + ppr pat = ppPattern (patternContextElements pat) (patternValueElements pat) + +instance Pretty (PatElemT b) => Pretty (PatElemT (a,b)) where + ppr = ppr . fmap snd + +instance Pretty (PatElemT Type) where + ppr (PatElem name t) = ppr t <+> ppr name + +instance Pretty (Param b) => Pretty (Param (a,b)) where + ppr = ppr . fmap snd + +instance Pretty (Param DeclType) where + ppr (Param name t) = + ppr t <+> + ppr name + +instance Pretty (Param Type) where + ppr (Param name t) = + ppr t <+> + ppr name + +instance PrettyLore lore => Pretty (Stm lore) where + ppr bnd@(Let pat (StmAux cs _ dec) e) = + stmannot $ align $ hang 2 $ + text "let" <+> align (ppr pat) <+> + case (linebreak, ppExpLore dec e) of + (True, Nothing) -> equals e' + (_, Just ann) -> equals (ann e') + (False, Nothing) -> equals <+/> e' + where e' | linebreak = ppr cs ppr e + | otherwise = ppr cs <> ppr e + linebreak = case e of + DoLoop{} -> True + Op{} -> True + If{} -> True + Apply{} -> True + BasicOp ArrayLit{} -> False + BasicOp Assert{} -> True + _ -> cs /= mempty + + stmannot = + case attrAnnots bnd <> + mapMaybe ppAnnot (patternElements $ stmPattern bnd) of + [] -> id + annots -> (stack annots ) + +instance Pretty BasicOp where + ppr (SubExp se) = ppr se + ppr (Opaque e) = text "opaque" <> apply [ppr e] + ppr (ArrayLit [] rt) = + text "empty" <> parens (ppr rt) + ppr (ArrayLit es rt) = + case rt of + Array {} -> brackets $ commastack $ map ppr es + _ -> brackets $ commasep $ map ppr es + ppr (BinOp bop x y) = ppr bop <> parens (ppr x <> comma <+> ppr y) + ppr (CmpOp op x y) = ppr op <> parens (ppr x <> comma <+> ppr y) + ppr (ConvOp conv x) = + text (convOpFun conv) <+> ppr fromtype <+> ppr x <+> text "to" <+> ppr totype + where (fromtype, totype) = convOpType conv + ppr (UnOp op e) = ppr op <+> pprPrec 9 e + ppr (Index v idxs) = + ppr v <> brackets (commasep (map ppr idxs)) + ppr (Update src idxs se) = + ppr src <+> text "with" <+> brackets (commasep (map ppr idxs)) <+> + text "<-" <+> ppr se + ppr (Iota e x s et) = text "iota" <> et' <> apply [ppr e, ppr x, ppr s] + where et' = text $ show $ primBitSize $ IntType et + ppr (Replicate ne ve) = + text "replicate" <> apply [ppr ne, align (ppr ve)] + ppr (Repeat shapes innershape v) = + text "repeat" <> apply [apply $ map ppr $ shapes ++ [innershape], ppr v] + ppr (Scratch t shape) = + text "scratch" <> apply (ppr t : map ppr shape) + ppr (Reshape shape e) = + text "reshape" <> apply [apply (map ppr shape), ppr e] + ppr (Rearrange perm e) = + text "rearrange" <> apply [apply (map ppr perm), ppr e] + ppr (Rotate es e) = + text "rotate" <> apply [apply (map ppr es), ppr e] + ppr (Concat i x ys _) = + text "concat" <> text "@" <> ppr i <> apply (ppr x : map ppr ys) + ppr (Copy e) = text "copy" <> parens (ppr e) + ppr (Manifest perm e) = text "manifest" <> apply [apply (map ppr perm), ppr e] + ppr (Assert e msg (loc, _)) = + text "assert" <> apply [ppr e, ppr msg, text $ show $ locStr loc] + +instance Pretty a => Pretty (ErrorMsg a) where + ppr (ErrorMsg parts) = commasep $ map p parts + where p (ErrorString s) = text $ show s + p (ErrorInt32 x) = ppr x + +instance PrettyLore lore => Pretty (Exp lore) where + ppr (If c t f (IfDec _ ifsort)) = + text "if" <+> info' <+> ppr c + text "then" <+> maybeNest t <+> + text "else" <+> maybeNest f + where info' = case ifsort of IfNormal -> mempty + IfFallback -> text "" + IfEquiv -> text "" + maybeNest b | null $ bodyStms b = ppr b + | otherwise = nestedBlock "{" "}" $ ppr b + ppr (BasicOp op) = ppr op + ppr (Apply fname args _ (safety, _, _)) = + text (nameToString fname) <> safety' <> apply (map (align . pprArg) args) + where pprArg (arg, Consume) = text "*" <> ppr arg + pprArg (arg, _) = ppr arg + safety' = case safety of Unsafe -> text "" + Safe -> mempty + ppr (Op op) = ppr op + ppr (DoLoop ctx val form loopbody) = + annot (mapMaybe ppAnnot (ctxparams++valparams)) $ + text "loop" <+> ppPattern ctxparams valparams <+> + equals <+> ppTuple' (ctxinit++valinit) + (case form of + ForLoop i it bound [] -> + text "for" <+> align (ppr i <> text ":" <> ppr it <+> + text "<" <+> align (ppr bound)) + ForLoop i it bound loop_vars -> + annot (mapMaybe (ppAnnot . fst) loop_vars) $ + text "for" <+> align (ppr i <> text ":" <> ppr it <+> + text "<" <+> align (ppr bound) + stack (map pprLoopVar loop_vars)) + WhileLoop cond -> + text "while" <+> ppr cond + ) <+> text "do" <+> nestedBlock "{" "}" (ppr loopbody) + where (ctxparams, ctxinit) = unzip ctx + (valparams, valinit) = unzip val + pprLoopVar (p,a) = ppr p <+> text "in" <+> ppr a + +instance PrettyLore lore => Pretty (Lambda lore) where + ppr (Lambda [] _ []) = text "nilFn" + ppr (Lambda params body rettype) = + annot (mapMaybe ppAnnot params) $ + text "fn" <+> ppTuple' rettype <+/> + align (parens (commasep (map ppr params))) <+> + text "=>" indent 2 (ppr body) + +instance PrettyLore lore => Pretty (FunDef lore) where + ppr (FunDef entry name rettype fparams body) = + annot (mapMaybe ppAnnot fparams) $ + text fun <+> ppTuple' rettype <+/> + text (nameToString name) <+> + apply (map ppr fparams) <+> + equals <+> nestedBlock "{" "}" (ppr body) + where fun | isJust entry = "entry" + | otherwise = "fun" + +instance PrettyLore lore => Pretty (Prog lore) where + ppr (Prog consts funs) = + stack $ punctuate line $ ppr consts : map ppr funs + +instance Pretty d => Pretty (DimChange d) where + ppr (DimCoercion se) = text "~" <> ppr se + ppr (DimNew se) = ppr se + +instance Pretty d => Pretty (DimIndex d) where + ppr (DimFix i) = ppr i + ppr (DimSlice i n s) = ppr i <> text ":+" <> ppr n <> text "*" <> ppr s + +ppPattern :: (Pretty a, Pretty b) => [a] -> [b] -> Doc +ppPattern [] bs = braces $ commasep $ map ppr bs +ppPattern as bs = braces $ commasep (map ppr as) <> semi commasep (map ppr bs) + +-- | Like 'prettyTuple', but produces a 'Doc'. +ppTuple' :: Pretty a => [a] -> Doc +ppTuple' ets = braces $ commasep $ map ppr ets diff --git a/src/Futhark/IR/Primitive.hs b/src/Futhark/IR/Primitive.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/IR/Primitive.hs @@ -0,0 +1,1292 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE Safe #-} +-- | Definitions of primitive types, the values that inhabit these +-- types, and operations on these values. A primitive value can also +-- be called a scalar. +-- +-- Essentially, this module describes the subset of the (internal) +-- Futhark language that operates on primitive types. +module Futhark.IR.Primitive + ( -- * Types + IntType (..), allIntTypes + , FloatType (..), allFloatTypes + , PrimType (..), allPrimTypes + + -- * Values + , IntValue(..) + , intValue, intValueType, valueIntegral + , FloatValue(..) + , floatValue, floatValueType + , PrimValue(..) + , primValueType + , blankPrimValue + + -- * Operations + , Overflow (..) + , UnOp (..), allUnOps + , BinOp (..), allBinOps + , ConvOp (..), allConvOps + , CmpOp (..), allCmpOps + + -- ** Unary Operations + , doUnOp + , doComplement + , doAbs, doFAbs + , doSSignum, doUSignum + + -- ** Binary Operations + , doBinOp + , doAdd, doMul, doSDiv, doSMod + , doPow + + -- ** Conversion Operations + , doConvOp + , doZExt, doSExt + , doFPConv + , doFPToUI, doFPToSI + , doUIToFP, doSIToFP + , intToInt64, intToWord64 + + -- * Comparison Operations + , doCmpOp + , doCmpEq + , doCmpUlt, doCmpUle + , doCmpSlt, doCmpSle + , doFCmpLt, doFCmpLe + + -- * Type Of + , binOpType + , unOpType + , cmpOpType + , convOpType + + -- * Primitive functions + , primFuns + + -- * Utility + , zeroIsh + , zeroIshInt + , oneIsh + , oneIshInt + , negativeIsh + , primBitSize + , primByteSize + , intByteSize + , floatByteSize + , commutativeBinOp + + -- * Prettyprinting + , convOpFun + , prettySigned + ) + where + +import Control.Applicative +import qualified Data.Binary.Get as G +import qualified Data.Binary.Put as P +import Data.Bits +import Data.Fixed (mod') -- Weird location. +import Data.Int (Int16, Int32, Int64, Int8) +import qualified Data.Map as M +import Data.Word + +import Prelude + +import Futhark.Util.Pretty +import Futhark.Util (roundFloat, ceilFloat, floorFloat, + roundDouble, ceilDouble, floorDouble, + lgamma, lgammaf, tgamma, tgammaf) + +-- | An integer type, ordered by size. Note that signedness is not a +-- property of the type, but a property of the operations performed on +-- values of these types. +data IntType = Int8 + | Int16 + | Int32 + | Int64 + deriving (Eq, Ord, Show, Enum, Bounded) + +instance Pretty IntType where + ppr Int8 = text "i8" + ppr Int16 = text "i16" + ppr Int32 = text "i32" + ppr Int64 = text "i64" + +-- | A list of all integer types. +allIntTypes :: [IntType] +allIntTypes = [minBound..maxBound] + +-- | A floating point type. +data FloatType = Float32 + | Float64 + deriving (Eq, Ord, Show, Enum, Bounded) + +instance Pretty FloatType where + ppr Float32 = text "f32" + ppr Float64 = text "f64" + +-- | A list of all floating-point types. +allFloatTypes :: [FloatType] +allFloatTypes = [minBound..maxBound] + +-- | Low-level primitive types. +data PrimType = IntType IntType + | FloatType FloatType + | Bool + | Cert + deriving (Eq, Ord, Show) + +instance Enum PrimType where + toEnum 0 = IntType Int8 + toEnum 1 = IntType Int16 + toEnum 2 = IntType Int32 + toEnum 3 = IntType Int64 + toEnum 4 = FloatType Float32 + toEnum 5 = FloatType Float64 + toEnum 6 = Bool + toEnum _ = Cert + + fromEnum (IntType Int8) = 0 + fromEnum (IntType Int16) = 1 + fromEnum (IntType Int32) = 2 + fromEnum (IntType Int64) = 3 + fromEnum (FloatType Float32) = 4 + fromEnum (FloatType Float64) = 5 + fromEnum Bool = 6 + fromEnum Cert = 7 + +instance Bounded PrimType where + minBound = IntType Int8 + maxBound = Cert + +instance Pretty PrimType where + ppr (IntType t) = ppr t + ppr (FloatType t) = ppr t + ppr Bool = text "bool" + ppr Cert = text "cert" + +-- | A list of all primitive types. +allPrimTypes :: [PrimType] +allPrimTypes = map IntType allIntTypes ++ + map FloatType allFloatTypes ++ + [Bool, Cert] + +-- | An integer value. +data IntValue = Int8Value !Int8 + | Int16Value !Int16 + | Int32Value !Int32 + | Int64Value !Int64 + deriving (Eq, Ord, Show) + +instance Pretty IntValue where + ppr (Int8Value v) = text $ show v ++ "i8" + ppr (Int16Value v) = text $ show v ++ "i16" + ppr (Int32Value v) = text $ show v ++ "i32" + ppr (Int64Value v) = text $ show v ++ "i64" + +-- | Create an t'IntValue' from a type and an 'Integer'. +intValue :: Integral int => IntType -> int -> IntValue +intValue Int8 = Int8Value . fromIntegral +intValue Int16 = Int16Value . fromIntegral +intValue Int32 = Int32Value . fromIntegral +intValue Int64 = Int64Value . fromIntegral + +-- | The type of an integer value. +intValueType :: IntValue -> IntType +intValueType Int8Value{} = Int8 +intValueType Int16Value{} = Int16 +intValueType Int32Value{} = Int32 +intValueType Int64Value{} = Int64 + +-- | Convert an t'IntValue' to any 'Integral' type. +valueIntegral :: Integral int => IntValue -> int +valueIntegral (Int8Value v) = fromIntegral v +valueIntegral (Int16Value v) = fromIntegral v +valueIntegral (Int32Value v) = fromIntegral v +valueIntegral (Int64Value v) = fromIntegral v + +-- | A floating-point value. +data FloatValue = Float32Value !Float + | Float64Value !Double + deriving (Eq, Ord, Show) + + +instance Pretty FloatValue where + ppr (Float32Value v) + | isInfinite v, v >= 0 = text "f32.inf" + | isInfinite v, v < 0 = text "-f32.inf" + | isNaN v = text "f32.nan" + | otherwise = text $ show v ++ "f32" + ppr (Float64Value v) + | isInfinite v, v >= 0 = text "f64.inf" + | isInfinite v, v < 0 = text "-f64.inf" + | isNaN v = text "f64.nan" + | otherwise = text $ show v ++ "f64" + +-- | Create a t'FloatValue' from a type and a 'Rational'. +floatValue :: Real num => FloatType -> num -> FloatValue +floatValue Float32 = Float32Value . fromRational . toRational +floatValue Float64 = Float64Value . fromRational . toRational + +-- | The type of a floating-point value. +floatValueType :: FloatValue -> FloatType +floatValueType Float32Value{} = Float32 +floatValueType Float64Value{} = Float64 + +-- | Non-array values. +data PrimValue = IntValue !IntValue + | FloatValue !FloatValue + | BoolValue !Bool + | Checked -- ^ The only value of type @cert@. + deriving (Eq, Ord, Show) + +instance Pretty PrimValue where + ppr (IntValue v) = ppr v + ppr (BoolValue True) = text "true" + ppr (BoolValue False) = text "false" + ppr (FloatValue v) = ppr v + ppr Checked = text "checked" + +-- | The type of a basic value. +primValueType :: PrimValue -> PrimType +primValueType (IntValue v) = IntType $ intValueType v +primValueType (FloatValue v) = FloatType $ floatValueType v +primValueType BoolValue{} = Bool +primValueType Checked = Cert + +-- | A "blank" value of the given primitive type - this is zero, or +-- whatever is close to it. Don't depend on this value, but use it +-- for e.g. creating arrays to be populated by do-loops. +blankPrimValue :: PrimType -> PrimValue +blankPrimValue (IntType Int8) = IntValue $ Int8Value 0 +blankPrimValue (IntType Int16) = IntValue $ Int16Value 0 +blankPrimValue (IntType Int32) = IntValue $ Int32Value 0 +blankPrimValue (IntType Int64) = IntValue $ Int64Value 0 +blankPrimValue (FloatType Float32) = FloatValue $ Float32Value 0.0 +blankPrimValue (FloatType Float64) = FloatValue $ Float64Value 0.0 +blankPrimValue Bool = BoolValue False +blankPrimValue Cert = Checked + +-- | Various unary operators. It is a bit ad-hoc what is a unary +-- operator and what is a built-in function. Perhaps these should all +-- go away eventually. +data UnOp = Not -- ^ E.g., @! True == False@. + | Complement IntType -- ^ E.g., @~(~1) = 1@. + | Abs IntType -- ^ @abs(-2) = 2@. + | FAbs FloatType -- ^ @fabs(-2.0) = 2.0@. + | SSignum IntType -- ^ Signed sign function: @ssignum(-2)@ = -1. + | USignum IntType -- ^ Unsigned sign function: @usignum(2)@ = 1. + deriving (Eq, Ord, Show) + +-- | What to do in case of arithmetic overflow. Futhark's semantics +-- are that overflow does wraparound, but for generated code (like +-- address arithmetic), it can be beneficial for overflow to be +-- undefined behaviour, as it allows better optimisation of things +-- such as GPU kernels. +-- +-- Note that all values of this type are considered equal for 'Eq' and +-- 'Ord'. +data Overflow = OverflowWrap | OverflowUndef + deriving (Show) + +instance Eq Overflow where + _ == _ = True + +instance Ord Overflow where + _ `compare` _ = EQ + +-- | Binary operators. These correspond closely to the binary operators in +-- LLVM. Most are parametrised by their expected input and output +-- types. +data BinOp = Add IntType Overflow -- ^ Integer addition. + | FAdd FloatType -- ^ Floating-point addition. + + | Sub IntType Overflow -- ^ Integer subtraction. + | FSub FloatType -- ^ Floating-point subtraction. + + | Mul IntType Overflow -- ^ Integer multiplication. + | FMul FloatType -- ^ Floating-point multiplication. + + | UDiv IntType + -- ^ Unsigned integer division. Rounds towards + -- negativity infinity. Note: this is different + -- from LLVM. + | SDiv IntType + -- ^ Signed integer division. Rounds towards + -- negativity infinity. Note: this is different + -- from LLVM. + | FDiv FloatType -- ^ Floating-point division. + | FMod FloatType -- ^ Floating-point modulus. + + | UMod IntType + -- ^ Unsigned integer modulus; the countepart to 'UDiv'. + | SMod IntType + -- ^ Signed integer modulus; the countepart to 'SDiv'. + + | SQuot IntType + -- ^ Signed integer division. Rounds towards zero. + -- This corresponds to the @sdiv@ instruction in LLVM. + | SRem IntType + -- ^ Signed integer division. Rounds towards zero. + -- This corresponds to the @srem@ instruction in LLVM. + + | SMin IntType + -- ^ Returns the smallest of two signed integers. + | UMin IntType + -- ^ Returns the smallest of two unsigned integers. + | FMin FloatType + -- ^ Returns the smallest of two floating-point numbers. + | SMax IntType + -- ^ Returns the greatest of two signed integers. + | UMax IntType + -- ^ Returns the greatest of two unsigned integers. + | FMax FloatType + -- ^ Returns the greatest of two floating-point numbers. + + | Shl IntType -- ^ Left-shift. + | LShr IntType -- ^ Logical right-shift, zero-extended. + | AShr IntType -- ^ Arithmetic right-shift, sign-extended. + + | And IntType -- ^ Bitwise and. + | Or IntType -- ^ Bitwise or. + | Xor IntType -- ^ Bitwise exclusive-or. + + | Pow IntType -- ^ Integer exponentiation. + | FPow FloatType -- ^ Floating-point exponentiation. + + | LogAnd -- ^ Boolean and - not short-circuiting. + | LogOr -- ^ Boolean or - not short-circuiting. + deriving (Eq, Ord, Show) + +-- | Comparison operators are like 'BinOp's, but they always return a +-- boolean value. The somewhat ugly constructor names are straight +-- out of LLVM. +data CmpOp = CmpEq PrimType -- ^ All types equality. + | CmpUlt IntType -- ^ Unsigned less than. + | CmpUle IntType -- ^ Unsigned less than or equal. + | CmpSlt IntType -- ^ Signed less than. + | CmpSle IntType -- ^ Signed less than or equal. + + -- Comparison operators for floating-point values. TODO: extend + -- this to handle NaNs and such, like the LLVM fcmp instruction. + | FCmpLt FloatType -- ^ Floating-point less than. + | FCmpLe FloatType -- ^ Floating-point less than or equal. + + -- Boolean comparison. + | CmpLlt -- ^ Boolean less than. + | CmpLle -- ^ Boolean less than or equal. + deriving (Eq, Ord, Show) + +-- | Conversion operators try to generalise the @from t0 x to t1@ +-- instructions from LLVM. +data ConvOp = ZExt IntType IntType + -- ^ Zero-extend the former integer type to the latter. + -- If the new type is smaller, the result is a + -- truncation. + | SExt IntType IntType + -- ^ Sign-extend the former integer type to the latter. + -- If the new type is smaller, the result is a + -- truncation. + | FPConv FloatType FloatType + -- ^ Convert value of the former floating-point type to + -- the latter. If the new type is smaller, the result + -- is a truncation. + | FPToUI FloatType IntType + -- ^ Convert a floating-point value to the nearest + -- unsigned integer (rounding towards zero). + | FPToSI FloatType IntType + -- ^ Convert a floating-point value to the nearest + -- signed integer (rounding towards zero). + | UIToFP IntType FloatType + -- ^ Convert an unsigned integer to a floating-point value. + | SIToFP IntType FloatType + -- ^ Convert a signed integer to a floating-point value. + | IToB IntType + -- ^ Convert an integer to a boolean value. Zero + -- becomes false; anything else is true. + | BToI IntType + -- ^ Convert a boolean to an integer. True is converted + -- to 1 and False to 0. + deriving (Eq, Ord, Show) + +-- | A list of all unary operators for all types. +allUnOps :: [UnOp] +allUnOps = Not : + map Complement [minBound..maxBound] ++ + map Abs [minBound..maxBound] ++ + map FAbs [minBound..maxBound] ++ + map SSignum [minBound..maxBound] ++ + map USignum [minBound..maxBound] + +-- | A list of all binary operators for all types. +allBinOps :: [BinOp] +allBinOps = concat [ map (`Add` OverflowWrap) allIntTypes + , map FAdd allFloatTypes + , map (`Sub` OverflowWrap) allIntTypes + , map FSub allFloatTypes + , map (`Mul` OverflowWrap) allIntTypes + , map FMul allFloatTypes + , map UDiv allIntTypes + , map SDiv allIntTypes + , map FDiv allFloatTypes + , map FMod allFloatTypes + , map UMod allIntTypes + , map SMod allIntTypes + , map SQuot allIntTypes + , map SRem allIntTypes + , map SMin allIntTypes + , map UMin allIntTypes + , map FMin allFloatTypes + , map SMax allIntTypes + , map UMax allIntTypes + , map FMax allFloatTypes + , map Shl allIntTypes + , map LShr allIntTypes + , map AShr allIntTypes + , map And allIntTypes + , map Or allIntTypes + , map Xor allIntTypes + , map Pow allIntTypes + , map FPow allFloatTypes + , [LogAnd, LogOr] + ] + +-- | A list of all comparison operators for all types. +allCmpOps :: [CmpOp] +allCmpOps = concat [ map CmpEq allPrimTypes + , map CmpUlt allIntTypes + , map CmpUle allIntTypes + , map CmpSlt allIntTypes + , map CmpSle allIntTypes + , map FCmpLt allFloatTypes + , map FCmpLe allFloatTypes + ] + +-- | A list of all conversion operators for all types. +allConvOps :: [ConvOp] +allConvOps = concat [ ZExt <$> allIntTypes <*> allIntTypes + , SExt <$> allIntTypes <*> allIntTypes + , FPConv <$> allFloatTypes <*> allFloatTypes + , FPToUI <$> allFloatTypes <*> allIntTypes + , FPToSI <$> allFloatTypes <*> allIntTypes + , UIToFP <$> allIntTypes <*> allFloatTypes + , SIToFP <$> allIntTypes <*> allFloatTypes + , IToB <$> allIntTypes + , BToI <$> allIntTypes + ] + +-- | Apply an 'UnOp' to an operand. Returns 'Nothing' if the +-- application is mistyped. +doUnOp :: UnOp -> PrimValue -> Maybe PrimValue +doUnOp Not (BoolValue b) = Just $ BoolValue $ not b +doUnOp Complement{} (IntValue v) = Just $ IntValue $ doComplement v +doUnOp Abs{} (IntValue v) = Just $ IntValue $ doAbs v +doUnOp FAbs{} (FloatValue v) = Just $ FloatValue $ doFAbs v +doUnOp SSignum{} (IntValue v) = Just $ IntValue $ doSSignum v +doUnOp USignum{} (IntValue v) = Just $ IntValue $ doUSignum v +doUnOp _ _ = Nothing + +-- | E.g., @~(~1) = 1@. +doComplement :: IntValue -> IntValue +doComplement v = intValue (intValueType v) $ complement $ intToInt64 v + +-- | @abs(-2) = 2@. +doAbs :: IntValue -> IntValue +doAbs v = intValue (intValueType v) $ abs $ intToInt64 v + +-- | @abs(-2.0) = 2.0@. +doFAbs :: FloatValue -> FloatValue +doFAbs v = floatValue (floatValueType v) $ abs $ floatToDouble v + +-- | @ssignum(-2)@ = -1. +doSSignum :: IntValue -> IntValue +doSSignum v = intValue (intValueType v) $ signum $ intToInt64 v + +-- | @usignum(-2)@ = -1. +doUSignum :: IntValue -> IntValue +doUSignum v = intValue (intValueType v) $ signum $ intToWord64 v + +-- | Apply a 'BinOp' to an operand. Returns 'Nothing' if the +-- application is mistyped, or outside the domain (e.g. division by +-- zero). +doBinOp :: BinOp -> PrimValue -> PrimValue -> Maybe PrimValue +doBinOp Add{} = doIntBinOp doAdd +doBinOp FAdd{} = doFloatBinOp (+) (+) +doBinOp Sub{} = doIntBinOp doSub +doBinOp FSub{} = doFloatBinOp (-) (-) +doBinOp Mul{} = doIntBinOp doMul +doBinOp FMul{} = doFloatBinOp (*) (*) +doBinOp UDiv{} = doRiskyIntBinOp doUDiv +doBinOp SDiv{} = doRiskyIntBinOp doSDiv +doBinOp FDiv{} = doFloatBinOp (/) (/) +doBinOp FMod{} = doFloatBinOp mod' mod' +doBinOp UMod{} = doRiskyIntBinOp doUMod +doBinOp SMod{} = doRiskyIntBinOp doSMod +doBinOp SQuot{} = doRiskyIntBinOp doSQuot +doBinOp SRem{} = doRiskyIntBinOp doSRem +doBinOp SMin{} = doIntBinOp doSMin +doBinOp UMin{} = doIntBinOp doUMin +doBinOp FMin{} = doFloatBinOp min min +doBinOp SMax{} = doIntBinOp doSMax +doBinOp UMax{} = doIntBinOp doUMax +doBinOp FMax{} = doFloatBinOp max max +doBinOp Shl{} = doIntBinOp doShl +doBinOp LShr{} = doIntBinOp doLShr +doBinOp AShr{} = doIntBinOp doAShr +doBinOp And{} = doIntBinOp doAnd +doBinOp Or{} = doIntBinOp doOr +doBinOp Xor{} = doIntBinOp doXor +doBinOp Pow{} = doRiskyIntBinOp doPow +doBinOp FPow{} = doFloatBinOp (**) (**) +doBinOp LogAnd{} = doBoolBinOp (&&) +doBinOp LogOr{} = doBoolBinOp (||) + +doIntBinOp :: (IntValue -> IntValue -> IntValue) -> PrimValue -> PrimValue + -> Maybe PrimValue +doIntBinOp f (IntValue v1) (IntValue v2) = + Just $ IntValue $ f v1 v2 +doIntBinOp _ _ _ = Nothing + +doRiskyIntBinOp :: (IntValue -> IntValue -> Maybe IntValue) -> PrimValue -> PrimValue + -> Maybe PrimValue +doRiskyIntBinOp f (IntValue v1) (IntValue v2) = + IntValue <$> f v1 v2 +doRiskyIntBinOp _ _ _ = Nothing + +doFloatBinOp :: (Float -> Float -> Float) + -> (Double -> Double -> Double) + -> PrimValue -> PrimValue + -> Maybe PrimValue +doFloatBinOp f32 _ (FloatValue (Float32Value v1)) (FloatValue (Float32Value v2)) = + Just $ FloatValue $ Float32Value $ f32 v1 v2 +doFloatBinOp _ f64 (FloatValue (Float64Value v1)) (FloatValue (Float64Value v2)) = + Just $ FloatValue $ Float64Value $ f64 v1 v2 +doFloatBinOp _ _ _ _ = Nothing + +doBoolBinOp :: (Bool -> Bool -> Bool) -> PrimValue -> PrimValue + -> Maybe PrimValue +doBoolBinOp f (BoolValue v1) (BoolValue v2) = + Just $ BoolValue $ f v1 v2 +doBoolBinOp _ _ _ = Nothing + +-- | Integer addition. +doAdd :: IntValue -> IntValue -> IntValue +doAdd v1 v2 = intValue (intValueType v1) $ intToInt64 v1 + intToInt64 v2 + +-- | Integer subtraction. +doSub :: IntValue -> IntValue -> IntValue +doSub v1 v2 = intValue (intValueType v1) $ intToInt64 v1 - intToInt64 v2 + +-- | Integer multiplication. +doMul :: IntValue -> IntValue -> IntValue +doMul v1 v2 = intValue (intValueType v1) $ intToInt64 v1 * intToInt64 v2 + +-- | Unsigned integer division. Rounds towards +-- negativity infinity. Note: this is different +-- from LLVM. +doUDiv :: IntValue -> IntValue -> Maybe IntValue +doUDiv v1 v2 + | zeroIshInt v2 = Nothing + | otherwise = Just $ intValue (intValueType v1) $ intToWord64 v1 `div` intToWord64 v2 + +-- | Signed integer division. Rounds towards +-- negativity infinity. Note: this is different +-- from LLVM. +doSDiv :: IntValue -> IntValue -> Maybe IntValue +doSDiv v1 v2 + | zeroIshInt v2 = Nothing + | otherwise = Just $ intValue (intValueType v1) $ intToInt64 v1 `div` intToInt64 v2 + +-- | Unsigned integer modulus; the countepart to 'UDiv'. +doUMod :: IntValue -> IntValue -> Maybe IntValue +doUMod v1 v2 + | zeroIshInt v2 = Nothing + | otherwise = Just $ intValue (intValueType v1) $ intToWord64 v1 `mod` intToWord64 v2 + +-- | Signed integer modulus; the countepart to 'SDiv'. +doSMod :: IntValue -> IntValue -> Maybe IntValue +doSMod v1 v2 + | zeroIshInt v2 = Nothing + | otherwise = Just $ intValue (intValueType v1) $ intToInt64 v1 `mod` intToInt64 v2 + +-- | Signed integer division. Rounds towards zero. +-- This corresponds to the @sdiv@ instruction in LLVM. +doSQuot :: IntValue -> IntValue -> Maybe IntValue +doSQuot v1 v2 + | zeroIshInt v2 = Nothing + | otherwise = Just $ intValue (intValueType v1) $ intToInt64 v1 `quot` intToInt64 v2 + +-- | Signed integer division. Rounds towards zero. +-- This corresponds to the @srem@ instruction in LLVM. +doSRem :: IntValue -> IntValue -> Maybe IntValue +doSRem v1 v2 + | zeroIshInt v2 = Nothing + | otherwise = Just $ intValue (intValueType v1) $ intToInt64 v1 `rem` intToInt64 v2 + +-- | Minimum of two signed integers. +doSMin :: IntValue -> IntValue -> IntValue +doSMin v1 v2 = intValue (intValueType v1) $ intToInt64 v1 `min` intToInt64 v2 + +-- | Minimum of two unsigned integers. +doUMin :: IntValue -> IntValue -> IntValue +doUMin v1 v2 = intValue (intValueType v1) $ intToWord64 v1 `min` intToWord64 v2 + +-- | Maximum of two signed integers. +doSMax :: IntValue -> IntValue -> IntValue +doSMax v1 v2 = intValue (intValueType v1) $ intToInt64 v1 `max` intToInt64 v2 + +-- | Maximum of two unsigned integers. +doUMax :: IntValue -> IntValue -> IntValue +doUMax v1 v2 = intValue (intValueType v1) $ intToWord64 v1 `max` intToWord64 v2 + +-- | Left-shift. +doShl :: IntValue -> IntValue -> IntValue +doShl v1 v2 = intValue (intValueType v1) $ intToInt64 v1 `shift` intToInt v2 + +-- | Logical right-shift, zero-extended. +doLShr :: IntValue -> IntValue -> IntValue +doLShr v1 v2 = intValue (intValueType v1) $ intToWord64 v1 `shift` negate (intToInt v2) + +-- | Arithmetic right-shift, sign-extended. +doAShr :: IntValue -> IntValue -> IntValue +doAShr v1 v2 = intValue (intValueType v1) $ intToInt64 v1 `shift` negate (intToInt v2) + +-- | Bitwise and. +doAnd :: IntValue -> IntValue -> IntValue +doAnd v1 v2 = intValue (intValueType v1) $ intToWord64 v1 .&. intToWord64 v2 + +-- | Bitwise or. +doOr :: IntValue -> IntValue -> IntValue +doOr v1 v2 = intValue (intValueType v1) $ intToWord64 v1 .|. intToWord64 v2 + +-- | Bitwise exclusive-or. +doXor :: IntValue -> IntValue -> IntValue +doXor v1 v2 = intValue (intValueType v1) $ intToWord64 v1 `xor` intToWord64 v2 + +-- | Signed integer exponentatation. +doPow :: IntValue -> IntValue -> Maybe IntValue +doPow v1 v2 + | negativeIshInt v2 = Nothing + | otherwise = Just $ intValue (intValueType v1) $ intToInt64 v1 ^ intToInt64 v2 + +-- | Apply a 'ConvOp' to an operand. Returns 'Nothing' if the +-- application is mistyped. +doConvOp :: ConvOp -> PrimValue -> Maybe PrimValue +doConvOp (ZExt _ to) (IntValue v) = Just $ IntValue $ doZExt v to +doConvOp (SExt _ to) (IntValue v) = Just $ IntValue $ doSExt v to +doConvOp (FPConv _ to) (FloatValue v) = Just $ FloatValue $ doFPConv v to +doConvOp (FPToUI _ to) (FloatValue v) = Just $ IntValue $ doFPToUI v to +doConvOp (FPToSI _ to) (FloatValue v) = Just $ IntValue $ doFPToSI v to +doConvOp (UIToFP _ to) (IntValue v) = Just $ FloatValue $ doUIToFP v to +doConvOp (SIToFP _ to) (IntValue v) = Just $ FloatValue $ doSIToFP v to +doConvOp (IToB _) (IntValue v) = Just $ BoolValue $ intToInt64 v /= 0 +doConvOp (BToI to) (BoolValue v) = Just $ IntValue $ intValue to $ if v then 1 else 0::Int +doConvOp _ _ = Nothing + +-- | Zero-extend the given integer value to the size of the given +-- type. If the type is smaller than the given value, the result is a +-- truncation. +doZExt :: IntValue -> IntType -> IntValue +doZExt (Int8Value x) t = intValue t $ toInteger (fromIntegral x :: Word8) +doZExt (Int16Value x) t = intValue t $ toInteger (fromIntegral x :: Word16) +doZExt (Int32Value x) t = intValue t $ toInteger (fromIntegral x :: Word32) +doZExt (Int64Value x) t = intValue t $ toInteger (fromIntegral x :: Word64) + +-- | Sign-extend the given integer value to the size of the given +-- type. If the type is smaller than the given value, the result is a +-- truncation. +doSExt :: IntValue -> IntType -> IntValue +doSExt (Int8Value x) t = intValue t $ toInteger x +doSExt (Int16Value x) t = intValue t $ toInteger x +doSExt (Int32Value x) t = intValue t $ toInteger x +doSExt (Int64Value x) t = intValue t $ toInteger x + +-- | Convert the former floating-point type to the latter. +doFPConv :: FloatValue -> FloatType -> FloatValue +doFPConv (Float32Value v) Float32 = Float32Value v +doFPConv (Float64Value v) Float32 = Float32Value $ fromRational $ toRational v +doFPConv (Float64Value v) Float64 = Float64Value v +doFPConv (Float32Value v) Float64 = Float64Value $ fromRational $ toRational v + +-- | Convert a floating-point value to the nearest +-- unsigned integer (rounding towards zero). +doFPToUI :: FloatValue -> IntType -> IntValue +doFPToUI v t = intValue t (truncate $ floatToDouble v :: Word64) + +-- | Convert a floating-point value to the nearest +-- signed integer (rounding towards zero). +doFPToSI :: FloatValue -> IntType -> IntValue +doFPToSI v t = intValue t (truncate $ floatToDouble v :: Word64) + +-- | Convert an unsigned integer to a floating-point value. +doUIToFP :: IntValue -> FloatType -> FloatValue +doUIToFP v t = floatValue t $ intToWord64 v + +-- | Convert a signed integer to a floating-point value. +doSIToFP :: IntValue -> FloatType -> FloatValue +doSIToFP v t = floatValue t $ intToInt64 v + +-- | Apply a 'CmpOp' to an operand. Returns 'Nothing' if the +-- application is mistyped. +doCmpOp :: CmpOp -> PrimValue -> PrimValue -> Maybe Bool +doCmpOp CmpEq{} v1 v2 = Just $ doCmpEq v1 v2 +doCmpOp CmpUlt{} (IntValue v1) (IntValue v2) = Just $ doCmpUlt v1 v2 +doCmpOp CmpUle{} (IntValue v1) (IntValue v2) = Just $ doCmpUle v1 v2 +doCmpOp CmpSlt{} (IntValue v1) (IntValue v2) = Just $ doCmpSlt v1 v2 +doCmpOp CmpSle{} (IntValue v1) (IntValue v2) = Just $ doCmpSle v1 v2 +doCmpOp FCmpLt{} (FloatValue v1) (FloatValue v2) = Just $ doFCmpLt v1 v2 +doCmpOp FCmpLe{} (FloatValue v1) (FloatValue v2) = Just $ doFCmpLe v1 v2 +doCmpOp CmpLlt{} (BoolValue v1) (BoolValue v2) = Just $ not v1 && v2 +doCmpOp CmpLle{} (BoolValue v1) (BoolValue v2) = Just $ not (v1 && not v2) +doCmpOp _ _ _ = Nothing + +-- | Compare any two primtive values for exact equality. +doCmpEq :: PrimValue -> PrimValue -> Bool +doCmpEq v1 v2 = v1 == v2 + +-- | Unsigned less than. +doCmpUlt :: IntValue -> IntValue -> Bool +doCmpUlt v1 v2 = intToWord64 v1 < intToWord64 v2 + +-- | Unsigned less than or equal. +doCmpUle :: IntValue -> IntValue -> Bool +doCmpUle v1 v2 = intToWord64 v1 <= intToWord64 v2 + +-- | Signed less than. +doCmpSlt :: IntValue -> IntValue -> Bool +doCmpSlt = (<) + +-- | Signed less than or equal. +doCmpSle :: IntValue -> IntValue -> Bool +doCmpSle = (<=) + +-- | Floating-point less than. +doFCmpLt :: FloatValue -> FloatValue -> Bool +doFCmpLt = (<) + +-- | Floating-point less than or equal. +doFCmpLe :: FloatValue -> FloatValue -> Bool +doFCmpLe = (<=) + +-- | Translate an t'IntValue' to 'Word64'. This is guaranteed to fit. +intToWord64 :: IntValue -> Word64 +intToWord64 (Int8Value v) = fromIntegral (fromIntegral v :: Word8) +intToWord64 (Int16Value v) = fromIntegral (fromIntegral v :: Word16) +intToWord64 (Int32Value v) = fromIntegral (fromIntegral v :: Word32) +intToWord64 (Int64Value v) = fromIntegral (fromIntegral v :: Word64) + +-- | Translate an t'IntValue' to t'Int64'. This is guaranteed to fit. +intToInt64 :: IntValue -> Int64 +intToInt64 (Int8Value v) = fromIntegral v +intToInt64 (Int16Value v) = fromIntegral v +intToInt64 (Int32Value v) = fromIntegral v +intToInt64 (Int64Value v) = fromIntegral v + +-- | Careful - there is no guarantee this will fit. +intToInt :: IntValue -> Int +intToInt = fromIntegral . intToInt64 + +floatToDouble :: FloatValue -> Double +floatToDouble (Float32Value v) = fromRational $ toRational v +floatToDouble (Float64Value v) = v + +-- | The result type of a binary operator. +binOpType :: BinOp -> PrimType +binOpType (Add t _) = IntType t +binOpType (Sub t _) = IntType t +binOpType (Mul t _) = IntType t +binOpType (SDiv t) = IntType t +binOpType (SMod t) = IntType t +binOpType (SQuot t) = IntType t +binOpType (SRem t) = IntType t +binOpType (UDiv t) = IntType t +binOpType (UMod t) = IntType t +binOpType (SMin t) = IntType t +binOpType (UMin t) = IntType t +binOpType (FMin t) = FloatType t +binOpType (SMax t) = IntType t +binOpType (UMax t) = IntType t +binOpType (FMax t) = FloatType t +binOpType (Shl t) = IntType t +binOpType (LShr t) = IntType t +binOpType (AShr t) = IntType t +binOpType (And t) = IntType t +binOpType (Or t) = IntType t +binOpType (Xor t) = IntType t +binOpType (Pow t) = IntType t +binOpType (FPow t) = FloatType t +binOpType LogAnd = Bool +binOpType LogOr = Bool +binOpType (FAdd t) = FloatType t +binOpType (FSub t) = FloatType t +binOpType (FMul t) = FloatType t +binOpType (FDiv t) = FloatType t +binOpType (FMod t) = FloatType t + +-- | The operand types of a comparison operator. +cmpOpType :: CmpOp -> PrimType +cmpOpType (CmpEq t) = t +cmpOpType (CmpSlt t) = IntType t +cmpOpType (CmpSle t) = IntType t +cmpOpType (CmpUlt t) = IntType t +cmpOpType (CmpUle t) = IntType t +cmpOpType (FCmpLt t) = FloatType t +cmpOpType (FCmpLe t) = FloatType t +cmpOpType CmpLlt = Bool +cmpOpType CmpLle = Bool + +-- | The operand and result type of a unary operator. +unOpType :: UnOp -> PrimType +unOpType (SSignum t) = IntType t +unOpType (USignum t) = IntType t +unOpType Not = Bool +unOpType (Complement t) = IntType t +unOpType (Abs t) = IntType t +unOpType (FAbs t) = FloatType t + +-- | The input and output types of a conversion operator. +convOpType :: ConvOp -> (PrimType, PrimType) +convOpType (ZExt from to) = (IntType from, IntType to) +convOpType (SExt from to) = (IntType from, IntType to) +convOpType (FPConv from to) = (FloatType from, FloatType to) +convOpType (FPToUI from to) = (FloatType from, IntType to) +convOpType (FPToSI from to) = (FloatType from, IntType to) +convOpType (UIToFP from to) = (IntType from, FloatType to) +convOpType (SIToFP from to) = (IntType from, FloatType to) +convOpType (IToB from) = (IntType from, Bool) +convOpType (BToI to) = (Bool, IntType to) + +floatToWord :: Float -> Word32 +floatToWord = G.runGet G.getWord32le . P.runPut . P.putFloatle + +wordToFloat :: Word32 -> Float +wordToFloat = G.runGet G.getFloatle . P.runPut . P.putWord32le + +doubleToWord :: Double -> Word64 +doubleToWord = G.runGet G.getWord64le . P.runPut . P.putDoublele + +wordToDouble :: Word64 -> Double +wordToDouble = G.runGet G.getDoublele . P.runPut . P.putWord64le + +-- | A mapping from names of primitive functions to their parameter +-- types, their result type, and a function for evaluating them. +primFuns :: M.Map String ([PrimType], PrimType, + [PrimValue] -> Maybe PrimValue) +primFuns = M.fromList + [ f32 "sqrt32" sqrt, f64 "sqrt64" sqrt + , f32 "log32" log, f64 "log64" log + , f32 "log10_32" (logBase 10), f64 "log10_64" (logBase 10) + , f32 "log2_32" (logBase 2), f64 "log2_64" (logBase 2) + , f32 "exp32" exp, f64 "exp64" exp + + , f32 "sin32" sin, f64 "sin64" sin + , f32 "sinh32" sinh, f64 "sinh64" sinh + , f32 "cos32" cos, f64 "cos64" cos + , f32 "cosh32" cosh, f64 "cosh64" cosh + , f32 "tan32" tan, f64 "tan64" tan + , f32 "tanh32" tanh, f64 "tanh64" tanh + , f32 "asin32" asin, f64 "asin64" asin + , f32 "asinh32" asinh, f64 "asinh64" asinh + , f32 "acos32" acos, f64 "acos64" acos + , f32 "acosh32" acosh, f64 "acosh64" acosh + , f32 "atan32" atan, f64 "atan64" atan + , f32 "atanh32" atanh, f64 "atanh64" atanh + + , f32 "round32" roundFloat, f64 "round64" roundDouble + , f32 "ceil32" ceilFloat, f64 "ceil64" ceilDouble + , f32 "floor32" floorFloat, f64 "floor64" floorDouble + , f32 "gamma32" tgammaf, f64 "gamma64" tgamma + , f32 "lgamma32" lgammaf, f64 "lgamma64" lgamma + + , i8 "clz8" $ IntValue . Int32Value . fromIntegral . countLeadingZeros + , i16 "clz16" $ IntValue . Int32Value . fromIntegral . countLeadingZeros + , i32 "clz32" $ IntValue . Int32Value . fromIntegral . countLeadingZeros + , i64 "clz64" $ IntValue . Int32Value . fromIntegral . countLeadingZeros + + , i8 "popc8" $ IntValue . Int32Value . fromIntegral . popCount + , i16 "popc16" $ IntValue . Int32Value . fromIntegral . popCount + , i32 "popc32" $ IntValue . Int32Value . fromIntegral . popCount + , i64 "popc64" $ IntValue . Int32Value . fromIntegral . popCount + + , ("mad_hi8", ([IntType Int8, IntType Int8, IntType Int8], IntType Int8, + \case + [IntValue (Int8Value a), IntValue (Int8Value b), IntValue (Int8Value c)] -> + Just $ IntValue . Int8Value $ mad_hi8 (Int8Value a) (Int8Value b) c + _ -> Nothing + )) + , ("mad_hi16", ([IntType Int16, IntType Int16, IntType Int16], IntType Int16, + \case + [IntValue (Int16Value a), IntValue (Int16Value b), IntValue (Int16Value c)] -> + Just $ IntValue . Int16Value $ mad_hi16 (Int16Value a) (Int16Value b) c + _ -> Nothing + )) + , ("mad_hi32", ([IntType Int32, IntType Int32, IntType Int32], IntType Int32, + \case + [IntValue (Int32Value a), IntValue (Int32Value b), IntValue (Int32Value c)] -> + Just $ IntValue . Int32Value $ mad_hi32 (Int32Value a) (Int32Value b) c + _ -> Nothing + )) + , ("mad_hi64", ([IntType Int64, IntType Int64, IntType Int64], IntType Int64, + \case + [IntValue (Int64Value a), IntValue (Int64Value b), IntValue (Int64Value c)] -> + Just $ IntValue . Int64Value $ mad_hi64 (Int64Value a) (Int64Value b) c + _ -> Nothing + )) + + , ("mul_hi8", ([IntType Int8, IntType Int8], IntType Int8, + \case + [IntValue (Int8Value a), IntValue (Int8Value b)] -> + Just $ IntValue . Int8Value $ mul_hi8 (Int8Value a) (Int8Value b) + _ -> Nothing + )) + , ("mul_hi16", ([IntType Int16, IntType Int16], IntType Int16, + \case + [IntValue (Int16Value a), IntValue (Int16Value b)] -> + Just $ IntValue . Int16Value $ mul_hi16 (Int16Value a) (Int16Value b) + _ -> Nothing + )) + , ("mul_hi32", ([IntType Int32, IntType Int32], IntType Int32, + \case + [IntValue (Int32Value a), IntValue (Int32Value b)] -> + Just $ IntValue . Int32Value $ mul_hi32 (Int32Value a) (Int32Value b) + _ -> Nothing + )) + , ("mul_hi64", ([IntType Int64, IntType Int64], IntType Int64, + \case + [IntValue (Int64Value a), IntValue (Int64Value b)] -> + Just $ IntValue . Int64Value $ mul_hi64 (Int64Value a) (Int64Value b) + _ -> Nothing + )) + + , ("atan2_32", + ([FloatType Float32, FloatType Float32], FloatType Float32, + \case + [FloatValue (Float32Value x), FloatValue (Float32Value y)] -> + Just $ FloatValue $ Float32Value $ atan2 x y + _ -> Nothing)) + , ("atan2_64", + ([FloatType Float64, FloatType Float64], FloatType Float64, + \case + [FloatValue (Float64Value x), FloatValue (Float64Value y)] -> + Just $ FloatValue $ Float64Value $ atan2 x y + _ -> Nothing)) + + , ("isinf32", + ([FloatType Float32], Bool, + \case + [FloatValue (Float32Value x)] -> Just $ BoolValue $ isInfinite x + _ -> Nothing)) + , ("isinf64", + ([FloatType Float64], Bool, + \case + [FloatValue (Float64Value x)] -> Just $ BoolValue $ isInfinite x + _ -> Nothing)) + + , ("isnan32", + ([FloatType Float32], Bool, + \case + [FloatValue (Float32Value x)] -> Just $ BoolValue $ isNaN x + _ -> Nothing)) + , ("isnan64", + ([FloatType Float64], Bool, + \case + [FloatValue (Float64Value x)] -> Just $ BoolValue $ isNaN x + _ -> Nothing)) + + , ("to_bits32", + ([FloatType Float32], IntType Int32, + \case + [FloatValue (Float32Value x)] -> + Just $ IntValue $ Int32Value $ fromIntegral $ floatToWord x + _ -> Nothing)) + , ("to_bits64", + ([FloatType Float64], IntType Int64, + \case + [FloatValue (Float64Value x)] -> + Just $ IntValue $ Int64Value $ fromIntegral $ doubleToWord x + _ -> Nothing)) + + , ("from_bits32", + ([IntType Int32], FloatType Float32, + \case + [IntValue (Int32Value x)] -> + Just $ FloatValue $ Float32Value $ wordToFloat $ fromIntegral x + _ -> Nothing)) + , ("from_bits64", + ([IntType Int64], FloatType Float64, + \case + [IntValue (Int64Value x)] -> + Just $ FloatValue $ Float64Value $ wordToDouble $ fromIntegral x + _ -> Nothing)) + + , f32_3 "lerp32" (\v0 v1 t -> v0 + (v1-v0)*max 0 (min 1 t)) + , f64_3 "lerp64" (\v0 v1 t -> v0 + (v1-v0)*max 0 (min 1 t)) + + , f32_3 "mad32" (\a b c -> a*b+c) + , f64_3 "mad64" (\a b c -> a*b+c) + + , f32_3 "fma32" (\a b c -> a*b+c) + , f64_3 "fma64" (\a b c -> a*b+c) + + ] + where i8 s f = (s, ([IntType Int8], IntType Int32, i8PrimFun f)) + i16 s f = (s, ([IntType Int16], IntType Int32, i16PrimFun f)) + i32 s f = (s, ([IntType Int32], IntType Int32, i32PrimFun f)) + i64 s f = (s, ([IntType Int64], IntType Int32, i64PrimFun f)) + f32 s f = (s, ([FloatType Float32], FloatType Float32, f32PrimFun f)) + f64 s f = (s, ([FloatType Float64], FloatType Float64, f64PrimFun f)) + f32_3 s f = (s, ([FloatType Float32,FloatType Float32,FloatType Float32], + FloatType Float32, f32PrimFun3 f)) + f64_3 s f = (s, ([FloatType Float64,FloatType Float64,FloatType Float64], + FloatType Float64, f64PrimFun3 f)) + + i8PrimFun f [IntValue (Int8Value x)] = + Just $ f x + i8PrimFun _ _ = Nothing + + i16PrimFun f [IntValue (Int16Value x)] = + Just $ f x + i16PrimFun _ _ = Nothing + + i32PrimFun f [IntValue (Int32Value x)] = + Just $ f x + i32PrimFun _ _ = Nothing + + i64PrimFun f [IntValue (Int64Value x)] = + Just $ f x + i64PrimFun _ _ = Nothing + + f32PrimFun f [FloatValue (Float32Value x)] = + Just $ FloatValue $ Float32Value $ f x + f32PrimFun _ _ = Nothing + + f64PrimFun f [FloatValue (Float64Value x)] = + Just $ FloatValue $ Float64Value $ f x + f64PrimFun _ _ = Nothing + + f32PrimFun3 f [FloatValue (Float32Value a), + FloatValue (Float32Value b), + FloatValue (Float32Value c)] = + Just $ FloatValue $ Float32Value $ f a b c + f32PrimFun3 _ _ = Nothing + + f64PrimFun3 f [FloatValue (Float64Value a), + FloatValue (Float64Value b), + FloatValue (Float64Value c)] = + Just $ FloatValue $ Float64Value $ f a b c + f64PrimFun3 _ _ = Nothing + +-- | Is the given value kind of zero? +zeroIsh :: PrimValue -> Bool +zeroIsh (IntValue k) = zeroIshInt k +zeroIsh (FloatValue (Float32Value k)) = k == 0 +zeroIsh (FloatValue (Float64Value k)) = k == 0 +zeroIsh (BoolValue False) = True +zeroIsh _ = False + +-- | Is the given value kind of one? +oneIsh :: PrimValue -> Bool +oneIsh (IntValue k) = oneIshInt k +oneIsh (FloatValue (Float32Value k)) = k == 1 +oneIsh (FloatValue (Float64Value k)) = k == 1 +oneIsh (BoolValue True) = True +oneIsh _ = False + +-- | Is the given value kind of negative? +negativeIsh :: PrimValue -> Bool +negativeIsh (IntValue k) = negativeIshInt k +negativeIsh (FloatValue (Float32Value k)) = k < 0 +negativeIsh (FloatValue (Float64Value k)) = k < 0 +negativeIsh (BoolValue _) = False +negativeIsh Checked = False + +-- | Is the given integer value kind of zero? +zeroIshInt :: IntValue -> Bool +zeroIshInt (Int8Value k) = k == 0 +zeroIshInt (Int16Value k) = k == 0 +zeroIshInt (Int32Value k) = k == 0 +zeroIshInt (Int64Value k) = k == 0 + +-- | Is the given integer value kind of one? +oneIshInt :: IntValue -> Bool +oneIshInt (Int8Value k) = k == 1 +oneIshInt (Int16Value k) = k == 1 +oneIshInt (Int32Value k) = k == 1 +oneIshInt (Int64Value k) = k == 1 + +-- | Is the given integer value kind of negative? +negativeIshInt :: IntValue -> Bool +negativeIshInt (Int8Value k) = k < 0 +negativeIshInt (Int16Value k) = k < 0 +negativeIshInt (Int32Value k) = k < 0 +negativeIshInt (Int64Value k) = k < 0 + +-- | The size of a value of a given primitive type in bites. +primBitSize :: PrimType -> Int +primBitSize = (*8) . primByteSize + +-- | The size of a value of a given primitive type in eight-bit bytes. +primByteSize :: Num a => PrimType -> a +primByteSize (IntType t) = intByteSize t +primByteSize (FloatType t) = floatByteSize t +primByteSize Bool = 1 +primByteSize Cert = 1 + +-- | The size of a value of a given integer type in eight-bit bytes. +intByteSize :: Num a => IntType -> a +intByteSize Int8 = 1 +intByteSize Int16 = 2 +intByteSize Int32 = 4 +intByteSize Int64 = 8 + +-- | The size of a value of a given floating-point type in eight-bit bytes. +floatByteSize :: Num a => FloatType -> a +floatByteSize Float32 = 4 +floatByteSize Float64 = 8 + +-- | True if the given binary operator is commutative. +commutativeBinOp :: BinOp -> Bool +commutativeBinOp Add{} = True +commutativeBinOp FAdd{} = True +commutativeBinOp Mul{} = True +commutativeBinOp FMul{} = True +commutativeBinOp And{} = True +commutativeBinOp Or{} = True +commutativeBinOp Xor{} = True +commutativeBinOp LogOr{} = True +commutativeBinOp LogAnd{} = True +commutativeBinOp SMax{} = True +commutativeBinOp SMin{} = True +commutativeBinOp UMax{} = True +commutativeBinOp UMin{} = True +commutativeBinOp FMax{} = True +commutativeBinOp FMin{} = True +commutativeBinOp _ = False + +-- Prettyprinting instances + +instance Pretty BinOp where + ppr (Add t OverflowWrap) = taggedI "add" t + ppr (Add t OverflowUndef) = taggedI "add_nw" t + ppr (Sub t OverflowWrap) = taggedI "sub" t + ppr (Sub t OverflowUndef) = taggedI "sub_nw" t + ppr (Mul t OverflowWrap) = taggedI "mul" t + ppr (Mul t OverflowUndef) = taggedI "mul_nw" t + ppr (FAdd t) = taggedF "fadd" t + ppr (FSub t) = taggedF "fsub" t + ppr (FMul t) = taggedF "fmul" t + ppr (UDiv t) = taggedI "udiv" t + ppr (UMod t) = taggedI "umod" t + ppr (SDiv t) = taggedI "sdiv" t + ppr (SMod t) = taggedI "smod" t + ppr (SQuot t) = taggedI "squot" t + ppr (SRem t) = taggedI "srem" t + ppr (FDiv t) = taggedF "fdiv" t + ppr (FMod t) = taggedF "fmod" t + ppr (SMin t) = taggedI "smin" t + ppr (UMin t) = taggedI "umin" t + ppr (FMin t) = taggedF "fmin" t + ppr (SMax t) = taggedI "smax" t + ppr (UMax t) = taggedI "umax" t + ppr (FMax t) = taggedF "fmax" t + ppr (Shl t) = taggedI "shl" t + ppr (LShr t) = taggedI "lshr" t + ppr (AShr t) = taggedI "ashr" t + ppr (And t) = taggedI "and" t + ppr (Or t) = taggedI "or" t + ppr (Xor t) = taggedI "xor" t + ppr (Pow t) = taggedI "pow" t + ppr (FPow t) = taggedF "fpow" t + ppr LogAnd = text "logand" + ppr LogOr = text "logor" + +instance Pretty CmpOp where + ppr (CmpEq t) = text "eq_" <> ppr t + ppr (CmpUlt t) = taggedI "ult" t + ppr (CmpUle t) = taggedI "ule" t + ppr (CmpSlt t) = taggedI "slt" t + ppr (CmpSle t) = taggedI "sle" t + ppr (FCmpLt t) = taggedF "lt" t + ppr (FCmpLe t) = taggedF "le" t + ppr CmpLlt = text "llt" + ppr CmpLle = text "lle" + +instance Pretty ConvOp where + ppr op = convOp (convOpFun op) from to + where (from, to) = convOpType op + +instance Pretty UnOp where + ppr Not = text "not" + ppr (Abs t) = taggedI "abs" t + ppr (FAbs t) = taggedF "fabs" t + ppr (SSignum t) = taggedI "ssignum" t + ppr (USignum t) = taggedI "usignum" t + ppr (Complement t) = taggedI "complement" t + +-- | The human-readable name for a 'ConvOp'. This is used to expose +-- the 'ConvOp' in the @intrinsics@ module of a Futhark program. +convOpFun :: ConvOp -> String +convOpFun ZExt{} = "zext" +convOpFun SExt{} = "sext" +convOpFun FPConv{} = "fpconv" +convOpFun FPToUI{} = "fptoui" +convOpFun FPToSI{} = "fptosi" +convOpFun UIToFP{} = "uitofp" +convOpFun SIToFP{} = "sitofp" +convOpFun IToB{} = "itob" +convOpFun BToI{} = "btoi" + +taggedI :: String -> IntType -> Doc +taggedI s Int8 = text $ s ++ "8" +taggedI s Int16 = text $ s ++ "16" +taggedI s Int32 = text $ s ++ "32" +taggedI s Int64 = text $ s ++ "64" + +taggedF :: String -> FloatType -> Doc +taggedF s Float32 = text $ s ++ "32" +taggedF s Float64 = text $ s ++ "64" + +convOp :: (Pretty from, Pretty to) => String -> from -> to -> Doc +convOp s from to = text s <> text "_" <> ppr from <> text "_" <> ppr to + +-- | True if signed. Only makes a difference for integer types. +prettySigned :: Bool -> PrimType -> String +prettySigned True (IntType it) = 'u' : drop 1 (pretty it) +prettySigned _ t = pretty t + +mul_hi8 :: IntValue -> IntValue -> Int8 +mul_hi8 a b = + let a' = intToWord64 a + b' = intToWord64 b + in fromIntegral (shiftR (a' * b') 8) + +mul_hi16 :: IntValue -> IntValue -> Int16 +mul_hi16 a b = + let a' = intToWord64 a + b' = intToWord64 b + in fromIntegral (shiftR (a' * b') 16) + +mul_hi32 :: IntValue -> IntValue -> Int32 +mul_hi32 a b = + let a' = intToWord64 a + b' = intToWord64 b + in fromIntegral (shiftR (a' * b') 32) + +mul_hi64 :: IntValue -> IntValue -> Int64 +mul_hi64 a b = + let a' = (toInteger . intToWord64) a + b' = (toInteger . intToWord64) b + in fromIntegral (shiftR (a' * b') 64) + +mad_hi8 :: IntValue -> IntValue -> Int8 -> Int8 +mad_hi8 a b c = mul_hi8 a b + c + +mad_hi16 :: IntValue -> IntValue -> Int16 -> Int16 +mad_hi16 a b c = mul_hi16 a b + c + +mad_hi32 :: IntValue -> IntValue -> Int32 -> Int32 +mad_hi32 a b c = mul_hi32 a b + c + +mad_hi64 :: IntValue -> IntValue -> Int64 -> Int64 +mad_hi64 a b c = mul_hi64 a b + c diff --git a/src/Futhark/IR/Prop.hs b/src/Futhark/IR/Prop.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/IR/Prop.hs @@ -0,0 +1,223 @@ +{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances, ConstraintKinds #-} +{-# LANGUAGE Safe #-} +-- | This module provides various simple ways to query and manipulate +-- fundamental Futhark terms, such as types and values. The intent is to +-- keep "Futhark.IRrsentation.AST.Syntax" simple, and put whatever +-- embellishments we need here. This is an internal, desugared +-- representation. +module Futhark.IR.Prop + ( module Futhark.IR.Prop.Reshape + , module Futhark.IR.Prop.Rearrange + , module Futhark.IR.Prop.Types + , module Futhark.IR.Prop.Constants + , module Futhark.IR.Prop.TypeOf + , module Futhark.IR.Prop.Patterns + , module Futhark.IR.Prop.Names + , module Futhark.IR.RetType + + -- * Built-in functions + , isBuiltInFunction + , builtInFunctions + + -- * Extra tools + , asBasicOp + , safeExp + , subExpVars + , subExpVar + , shapeVars + , commutativeLambda + , entryPointSize + , defAux + , stmCerts + , certify + , expExtTypesFromPattern + + , ASTConstraints + , IsOp (..) + , ASTLore (..) + ) + where + +import Data.List (find) +import Data.Maybe (mapMaybe, isJust) +import qualified Data.Map.Strict as M + +import Futhark.IR.Prop.Reshape +import Futhark.IR.Prop.Rearrange +import Futhark.IR.Prop.Types +import Futhark.IR.Prop.Constants +import Futhark.IR.Prop.Patterns +import Futhark.IR.Prop.Names +import Futhark.IR.Prop.TypeOf +import Futhark.IR.RetType +import Futhark.IR.Syntax +import Futhark.IR.Pretty +import Futhark.Transform.Rename (Rename, Renameable) +import Futhark.Transform.Substitute (Substitute, Substitutable) +import Futhark.Util.Pretty + +-- | @isBuiltInFunction k@ is 'True' if @k@ is an element of 'builtInFunctions'. +isBuiltInFunction :: Name -> Bool +isBuiltInFunction fnm = fnm `M.member` builtInFunctions + +-- | A map of all built-in functions and their types. +builtInFunctions :: M.Map Name (PrimType,[PrimType]) +builtInFunctions = M.fromList $ map namify $ M.toList primFuns + where namify (k,(paramts,ret,_)) = (nameFromString k, (ret, paramts)) + +-- | If the expression is a t'BasicOp', return it, otherwise 'Nothing'. +asBasicOp :: Exp lore -> Maybe BasicOp +asBasicOp (BasicOp op) = Just op +asBasicOp _ = Nothing + +-- | An expression is safe if it is always well-defined (assuming that +-- any required certificates have been checked) in any context. For +-- example, array indexing is not safe, as the index may be out of +-- bounds. On the other hand, adding two numbers cannot fail. +safeExp :: IsOp (Op lore) => Exp lore -> Bool +safeExp (BasicOp op) = safeBasicOp op + where safeBasicOp (BinOp SDiv{} _ (Constant y)) = not $ zeroIsh y + safeBasicOp (BinOp SDiv{} _ _) = False + safeBasicOp (BinOp UDiv{} _ (Constant y)) = not $ zeroIsh y + safeBasicOp (BinOp UDiv{} _ _) = False + safeBasicOp (BinOp SMod{} _ (Constant y)) = not $ zeroIsh y + safeBasicOp (BinOp SMod{} _ _) = False + safeBasicOp (BinOp UMod{} _ (Constant y)) = not $ zeroIsh y + safeBasicOp (BinOp UMod{} _ _) = False + + safeBasicOp (BinOp SQuot{} _ (Constant y)) = not $ zeroIsh y + safeBasicOp (BinOp SQuot{} _ _) = False + safeBasicOp (BinOp SRem{} _ (Constant y)) = not $ zeroIsh y + safeBasicOp (BinOp SRem{} _ _) = False + + safeBasicOp (BinOp Pow{} _ (Constant y)) = not $ negativeIsh y + safeBasicOp (BinOp Pow{} _ _) = False + safeBasicOp ArrayLit{} = True + safeBasicOp BinOp{} = True + safeBasicOp SubExp{} = True + safeBasicOp UnOp{} = True + safeBasicOp CmpOp{} = True + safeBasicOp ConvOp{} = True + safeBasicOp Scratch{} = True + safeBasicOp Concat{} = True + safeBasicOp Reshape{} = True + safeBasicOp Rearrange{} = True + safeBasicOp Manifest{} = True + safeBasicOp Iota{} = True + safeBasicOp Replicate{} = True + safeBasicOp Copy{} = True + safeBasicOp _ = False + +safeExp (DoLoop _ _ _ body) = safeBody body +safeExp (Apply fname _ _ _) = + isBuiltInFunction fname +safeExp (If _ tbranch fbranch _) = + all (safeExp . stmExp) (bodyStms tbranch) && + all (safeExp . stmExp) (bodyStms fbranch) +safeExp (Op op) = safeOp op + +safeBody :: IsOp (Op lore) => Body lore -> Bool +safeBody = all (safeExp . stmExp) . bodyStms + +-- | Return the variable names used in 'Var' subexpressions. May contain +-- duplicates. +subExpVars :: [SubExp] -> [VName] +subExpVars = mapMaybe subExpVar + +-- | If the t'SubExp' is a 'Var' return the variable name. +subExpVar :: SubExp -> Maybe VName +subExpVar (Var v) = Just v +subExpVar Constant{} = Nothing + +-- | Return the variable dimension sizes. May contain +-- duplicates. +shapeVars :: Shape -> [VName] +shapeVars = subExpVars . shapeDims + +-- | Does the given lambda represent a known commutative function? +-- Based on pattern matching and checking whether the lambda +-- represents a known arithmetic operator; don't expect anything +-- clever here. +commutativeLambda :: Lambda lore -> Bool +commutativeLambda lam = + let body = lambdaBody lam + n2 = length (lambdaParams lam) `div` 2 + (xps,yps) = splitAt n2 (lambdaParams lam) + + okComponent c = isJust $ find (okBinOp c) $ bodyStms body + okBinOp (xp,yp,Var r) (Let (Pattern [] [pe]) _ (BasicOp (BinOp op (Var x) (Var y)))) = + patElemName pe == r && + commutativeBinOp op && + ((x == paramName xp && y == paramName yp) || + (y == paramName xp && x == paramName yp)) + okBinOp _ _ = False + + in n2 * 2 == length (lambdaParams lam) && + n2 == length (bodyResult body) && + all okComponent (zip3 xps yps $ bodyResult body) + +-- | How many value parameters are accepted by this entry point? This +-- is used to determine which of the function parameters correspond to +-- the parameters of the original function (they must all come at the +-- end). +entryPointSize :: EntryPointType -> Int +entryPointSize (TypeOpaque _ x) = x +entryPointSize TypeUnsigned = 1 +entryPointSize TypeDirect = 1 + +-- | A 'StmAux' with empty 'Certificates'. +defAux :: dec -> StmAux dec +defAux = StmAux mempty mempty + +-- | The certificates associated with a statement. +stmCerts :: Stm lore -> Certificates +stmCerts = stmAuxCerts . stmAux + +-- | Add certificates to a statement. +certify :: Certificates -> Stm lore -> Stm lore +certify cs1 (Let pat (StmAux cs2 attrs dec) e) = + Let pat (StmAux (cs2<>cs1) attrs dec) e + +-- | A handy shorthand for properties that we usually want to things +-- we stuff into ASTs. +type ASTConstraints a = + (Eq a, Ord a, Show a, Rename a, Substitute a, FreeIn a, Pretty a) + +-- | A type class for operations. +class (ASTConstraints op, TypedOp op) => IsOp op where + -- | Like 'safeExp', but for arbitrary ops. + safeOp :: op -> Bool + -- | Should we try to hoist this out of branches? + cheapOp :: op -> Bool + +instance IsOp () where + safeOp () = True + cheapOp () = True + +-- | Lore-specific attributes; also means the lore supports some basic +-- facilities. +class (Decorations lore, + + PrettyLore lore, + + Renameable lore, Substitutable lore, + FreeDec (ExpDec lore), + FreeIn (LetDec lore), + FreeDec (BodyDec lore), + FreeIn (FParamInfo lore), + FreeIn (LParamInfo lore), + FreeIn (RetType lore), + FreeIn (BranchType lore), + + IsOp (Op lore)) => ASTLore lore where + -- | Given a pattern, construct the type of a body that would match + -- it. An implementation for many lores would be + -- 'expExtTypesFromPattern'. + expTypesFromPattern :: (HasScope lore m, Monad m) => + Pattern lore -> m [BranchType lore] + +-- | Construct the type of an expression that would match the pattern. +expExtTypesFromPattern :: Typed dec => PatternT dec -> [ExtType] +expExtTypesFromPattern pat = + existentialiseExtTypes (patternContextNames pat) $ + staticShapes $ map patElemType $ patternValueElements pat diff --git a/src/Futhark/IR/Prop/Aliases.hs b/src/Futhark/IR/Prop/Aliases.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/IR/Prop/Aliases.hs @@ -0,0 +1,182 @@ +{-# LANGUAGE TypeFamilies #-} +{-# Language FlexibleInstances, FlexibleContexts #-} +-- | The IR tracks aliases, mostly to ensure the soundness of in-place +-- updates, but it can also be used for other things (such as memory +-- optimisations). This module contains the raw building blocks for +-- determining the aliases of the values produced by expressions. It +-- also contains some building blocks for inspecting consumption. +-- +-- One important caveat is that all aliases computed here are /local/. +-- Thus, they do not take aliases-of-aliases into account. See +-- "Futhark.Analysis.Alias" if this is not what you want. +module Futhark.IR.Prop.Aliases + ( subExpAliases + , expAliases + , patternAliases + , Aliased (..) + , AliasesOf (..) + -- * Consumption + , consumedInStm + , consumedInExp + , consumedByLambda + -- * Extensibility + , AliasedOp (..) + , CanBeAliased (..) + ) + where + +import Control.Arrow (first) +import qualified Data.Kind + +import Futhark.IR.Prop (IsOp) +import Futhark.IR.Syntax +import Futhark.IR.Prop.Patterns +import Futhark.IR.Prop.Types +import Futhark.IR.Prop.Names + +-- | The class of lores that contain aliasing information. +class (Decorations lore, AliasedOp (Op lore), + AliasesOf (LetDec lore)) => Aliased lore where + -- | The aliases of the body results. + bodyAliases :: Body lore -> [Names] + -- | The variables consumed in the body. + consumedInBody :: Body lore -> Names + +vnameAliases :: VName -> Names +vnameAliases = oneName + +-- | The alises of a subexpression. +subExpAliases :: SubExp -> Names +subExpAliases Constant{} = mempty +subExpAliases (Var v) = vnameAliases v + +basicOpAliases :: BasicOp -> [Names] +basicOpAliases (SubExp se) = [subExpAliases se] +basicOpAliases (Opaque se) = [subExpAliases se] +basicOpAliases (ArrayLit _ _) = [mempty] +basicOpAliases BinOp{} = [mempty] +basicOpAliases ConvOp{} = [mempty] +basicOpAliases CmpOp{} = [mempty] +basicOpAliases UnOp{} = [mempty] +basicOpAliases (Index ident _) = [vnameAliases ident] +basicOpAliases Update{} = [mempty] +basicOpAliases Iota{} = [mempty] +basicOpAliases Replicate{} = [mempty] +basicOpAliases (Repeat _ _ v) = [vnameAliases v] +basicOpAliases Scratch{} = [mempty] +basicOpAliases (Reshape _ e) = [vnameAliases e] +basicOpAliases (Rearrange _ e) = [vnameAliases e] +basicOpAliases (Rotate _ e) = [vnameAliases e] +basicOpAliases Concat{} = [mempty] +basicOpAliases Copy{} = [mempty] +basicOpAliases Manifest{} = [mempty] +basicOpAliases Assert{} = [mempty] + +ifAliases :: ([Names], Names) -> ([Names], Names) -> [Names] +ifAliases (als1,cons1) (als2,cons2) = + map (`namesSubtract` cons) $ zipWith mappend als1 als2 + where cons = cons1 <> cons2 + +funcallAliases :: [(SubExp, Diet)] -> [TypeBase shape Uniqueness] -> [Names] +funcallAliases args t = + returnAliases t [(subExpAliases se, d) | (se,d) <- args ] + +-- | The aliases of an expression, one per non-context value returned. +expAliases :: (Aliased lore) => Exp lore -> [Names] +expAliases (If _ tb fb dec) = + drop (length all_aliases - length ts) all_aliases + where ts = ifReturns dec + all_aliases = ifAliases + (bodyAliases tb, consumedInBody tb) + (bodyAliases fb, consumedInBody fb) +expAliases (BasicOp op) = basicOpAliases op +expAliases (DoLoop ctxmerge valmerge _ loopbody) = + map (`namesSubtract` merge_names) val_aliases + where (_ctx_aliases, val_aliases) = + splitAt (length ctxmerge) $ bodyAliases loopbody + merge_names = namesFromList $ map (paramName . fst) $ ctxmerge ++ valmerge +expAliases (Apply _ args t _) = + funcallAliases args $ map declExtTypeOf t +expAliases (Op op) = opAliases op + +returnAliases :: [TypeBase shape Uniqueness] -> [(Names, Diet)] -> [Names] +returnAliases rts args = map returnType' rts + where returnType' (Array _ _ Nonunique) = + mconcat $ map (uncurry maskAliases) args + returnType' (Array _ _ Unique) = + mempty + returnType' (Prim _) = + mempty + returnType' Mem{} = + error "returnAliases Mem" + +maskAliases :: Names -> Diet -> Names +maskAliases _ Consume = mempty +maskAliases _ ObservePrim = mempty +maskAliases als Observe = als + +-- | The variables consumed in this statement. +consumedInStm :: Aliased lore => Stm lore -> Names +consumedInStm = consumedInExp . stmExp + +-- | The variables consumed in this expression. +consumedInExp :: (Aliased lore) => Exp lore -> Names +consumedInExp (Apply _ args _ _) = + mconcat (map (consumeArg . first subExpAliases) args) + where consumeArg (als, Consume) = als + consumeArg _ = mempty +consumedInExp (If _ tb fb _) = + consumedInBody tb <> consumedInBody fb +consumedInExp (DoLoop _ merge _ _) = + mconcat (map (subExpAliases . snd) $ + filter (unique . paramDeclType . fst) merge) +consumedInExp (BasicOp (Update src _ _)) = oneName src +consumedInExp (Op op) = consumedInOp op +consumedInExp _ = mempty + +-- | The variables consumed by this lambda. +consumedByLambda :: Aliased lore => Lambda lore -> Names +consumedByLambda = consumedInBody . lambdaBody + +-- | The aliases of each pattern element (including the context). +patternAliases :: AliasesOf dec => PatternT dec -> [Names] +patternAliases = map (aliasesOf . patElemDec) . patternElements + +-- | Something that contains alias information. +class AliasesOf a where + -- | The alias of the argument element. + aliasesOf :: a -> Names + +instance AliasesOf Names where + aliasesOf = id + +instance AliasesOf dec => AliasesOf (PatElemT dec) where + aliasesOf = aliasesOf . patElemDec + +-- | The class of operations that can produce aliasing and consumption +-- information. +class IsOp op => AliasedOp op where + opAliases :: op -> [Names] + consumedInOp :: op -> Names + +instance AliasedOp () where + opAliases () = [] + consumedInOp () = mempty + +-- | The class of operations that can be given aliasing information. +-- This is a somewhat subtle concept that is only used in the +-- simplifier and when using "lore adapters". +class AliasedOp (OpWithAliases op) => CanBeAliased op where + -- | The op that results when we add aliases to this op. + type OpWithAliases op :: Data.Kind.Type + + -- | Remove aliases from this op. + removeOpAliases :: OpWithAliases op -> op + + -- | Add aliases to this op. + addOpAliases :: op -> OpWithAliases op + +instance CanBeAliased () where + type OpWithAliases () = () + removeOpAliases = id + addOpAliases = id diff --git a/src/Futhark/IR/Prop/Constants.hs b/src/Futhark/IR/Prop/Constants.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/IR/Prop/Constants.hs @@ -0,0 +1,76 @@ +-- | Possibly convenient facilities for constructing constants. +module Futhark.IR.Prop.Constants + ( + IsValue (..) + , constant + , intConst + , floatConst + ) + where + +import Futhark.IR.Syntax.Core + +-- | If a Haskell type is an instance of 'IsValue', it means that a +-- value of that type can be converted to a Futhark 'PrimValue'. +-- This is intended to cut down on boilerplate when writing compiler +-- code - for example, you'll quickly grow tired of writing @Constant +-- (LogVal True) loc@. +class IsValue a where + value :: a -> PrimValue + +instance IsValue Int where + value = IntValue . Int32Value . fromIntegral + +instance IsValue Int8 where + value = IntValue . Int8Value + +instance IsValue Int16 where + value = IntValue . Int16Value + +instance IsValue Int32 where + value = IntValue . Int32Value + +instance IsValue Int64 where + value = IntValue . Int64Value + +instance IsValue Word8 where + value = IntValue . Int8Value . fromIntegral + +instance IsValue Word16 where + value = IntValue . Int16Value . fromIntegral + +instance IsValue Word32 where + value = IntValue . Int32Value . fromIntegral + +instance IsValue Word64 where + value = IntValue . Int64Value . fromIntegral + +instance IsValue Double where + value = FloatValue . Float64Value + +instance IsValue Float where + value = FloatValue . Float32Value + +instance IsValue Bool where + value = BoolValue + +instance IsValue PrimValue where + value = id + +instance IsValue IntValue where + value = IntValue + +instance IsValue FloatValue where + value = FloatValue + +-- | Create a 'Constant' 'SubExp' containing the given value. +constant :: IsValue v => v -> SubExp +constant = Constant . value + +-- | Utility definition for reasons of type ambiguity. +intConst :: IntType -> Integer -> SubExp +intConst t v = constant $ intValue t v + +-- | Utility definition for reasons of type ambiguity. +floatConst :: FloatType -> Double -> SubExp +floatConst t v = constant $ floatValue t v diff --git a/src/Futhark/IR/Prop/Names.hs b/src/Futhark/IR/Prop/Names.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/IR/Prop/Names.hs @@ -0,0 +1,334 @@ +{-# LANGUAGE FlexibleInstances, FlexibleContexts, UndecidableInstances #-} +-- | Facilities for determining which names are used in some syntactic +-- construct. The most important interface is the 'FreeIn' class and +-- its instances, but for reasons related to the Haskell type system, +-- some constructs have specialised functions. +module Futhark.IR.Prop.Names + ( -- * Free names + Names + , nameIn + , oneName + , namesFromList + , namesToList + , namesIntersection + , namesIntersect + , namesSubtract + , mapNames + -- * Class + , FreeIn (..) + , freeIn + -- * Specialised Functions + , freeInStmsAndRes + -- * Bound Names + , boundInBody + , boundByStm + , boundByStms + , boundByLambda + -- * Efficient computation + , FreeDec(..) + , FV + , fvBind + , fvName + , fvNames + ) + where + +import Control.Monad.State.Strict +import qualified Data.IntMap.Strict as IM +import qualified Data.Map.Strict as M +import Data.Foldable + +import Futhark.IR.Syntax +import Futhark.IR.Traversals +import Futhark.IR.Prop.Patterns +import Futhark.IR.Prop.Scope +import Futhark.Util.Pretty + +-- | A set of names. +newtype Names = Names { unNames :: IM.IntMap VName } + deriving (Eq, Show) + +instance Semigroup Names where + vs1 <> vs2 = Names $ unNames vs1 <> unNames vs2 + +instance Monoid Names where + mempty = Names mempty + +instance Pretty Names where + ppr = ppr . namesToList + +-- | Does the set of names contain this name? +nameIn :: VName -> Names -> Bool +nameIn v (Names vs) = baseTag v `IM.member` vs + +-- | Construct a name set from a list. Slow. +namesFromList :: [VName] -> Names +namesFromList vs = Names $ IM.fromList $ zip (map baseTag vs) vs + +-- | Turn a name set into a list of names. Slow. +namesToList :: Names -> [VName] +namesToList = IM.elems . unNames + +-- | Construct a name set from a single name. +oneName :: VName -> Names +oneName v = Names $ IM.singleton (baseTag v) v + +-- | The intersection of two name sets. +namesIntersection :: Names -> Names -> Names +namesIntersection (Names vs1) (Names vs2) = Names $ IM.intersection vs1 vs2 + +-- | Do the two name sets intersect? +namesIntersect :: Names -> Names -> Bool +namesIntersect vs1 vs2 = not $ IM.disjoint (unNames vs1) (unNames vs2) + +-- | Subtract the latter name set from the former. +namesSubtract :: Names -> Names -> Names +namesSubtract (Names vs1) (Names vs2) = Names $ IM.difference vs1 vs2 + +-- | Map over the names in a set. +mapNames :: (VName -> VName) -> Names -> Names +mapNames f vs = namesFromList $ map f $ namesToList vs + +-- | A computation to build a free variable set. +newtype FV = FV { unFV :: Names } +-- Right now the variable set is just stored explicitly, without the +-- fancy functional representation that GHC uses. Turns out it's +-- faster this way. + +instance Monoid FV where + mempty = FV mempty + +instance Semigroup FV where + FV fv1 <> FV fv2 = FV $ fv1 <> fv2 + +-- | Consider a variable to be bound in the given 'FV' computation. +fvBind :: Names -> FV -> FV +fvBind vs (FV fv) = FV $ fv `namesSubtract` vs + +-- | Take note of a variable reference. +fvName :: VName -> FV +fvName v = FV $ oneName v + +-- | Take note of a set of variable references. +fvNames :: Names -> FV +fvNames = FV + +freeWalker :: (FreeDec (ExpDec lore), + FreeDec (BodyDec lore), + FreeIn (FParamInfo lore), + FreeIn (LParamInfo lore), + FreeIn (LetDec lore), + FreeIn (Op lore)) => + Walker lore (State FV) +freeWalker = identityWalker { + walkOnSubExp = modify . (<>) . freeIn' + , walkOnBody = modify . (<>) . freeIn' + , walkOnVName = modify . (<>) . fvName + , walkOnOp = modify . (<>) . freeIn' + } + +-- | Return the set of variable names that are free in the given +-- statements and result. Filters away the names that are bound by +-- the statements. +freeInStmsAndRes :: (FreeIn (Op lore), + FreeIn (LetDec lore), + FreeIn (LParamInfo lore), + FreeIn (FParamInfo lore), + FreeDec (BodyDec lore), + FreeDec (ExpDec lore)) => + Stms lore -> Result -> FV +freeInStmsAndRes stms res = + fvBind (boundByStms stms) $ foldMap freeIn' stms <> freeIn' res + +-- | A class indicating that we can obtain free variable information +-- from values of this type. +class FreeIn a where + freeIn' :: a -> FV + freeIn' = fvNames . freeIn + +-- | The free variables of some syntactic construct. +freeIn :: FreeIn a => a -> Names +freeIn = unFV . freeIn' + +instance FreeIn FV where + freeIn' = id + +instance FreeIn () where + freeIn' () = mempty + +instance FreeIn Int where + freeIn' = const mempty + +instance (FreeIn a, FreeIn b) => FreeIn (a,b) where + freeIn' (a,b) = freeIn' a <> freeIn' b + +instance (FreeIn a, FreeIn b, FreeIn c) => FreeIn (a,b,c) where + freeIn' (a,b,c) = freeIn' a <> freeIn' b <> freeIn' c + +instance FreeIn a => FreeIn [a] where + freeIn' = foldMap freeIn' + +instance (FreeDec (ExpDec lore), + FreeDec (BodyDec lore), + FreeIn (FParamInfo lore), + FreeIn (LParamInfo lore), + FreeIn (LetDec lore), + FreeIn (RetType lore), + FreeIn (Op lore)) => FreeIn (FunDef lore) where + freeIn' (FunDef _ _ rettype params body) = + fvBind (namesFromList $ map paramName params) $ + freeIn' rettype <> freeIn' params <> freeIn' body + +instance (FreeDec (ExpDec lore), + FreeDec (BodyDec lore), + FreeIn (FParamInfo lore), + FreeIn (LParamInfo lore), + FreeIn (LetDec lore), + FreeIn (Op lore)) => FreeIn (Lambda lore) where + freeIn' (Lambda params body rettype) = + fvBind (namesFromList $ map paramName params) $ + freeIn' rettype <> freeIn' params <> freeIn' body + +instance (FreeDec (ExpDec lore), + FreeDec (BodyDec lore), + FreeIn (FParamInfo lore), + FreeIn (LParamInfo lore), + FreeIn (LetDec lore), + FreeIn (Op lore)) => FreeIn (Body lore) where + freeIn' (Body dec stms res) = + precomputed dec $ freeIn' dec <> freeInStmsAndRes stms res + +instance (FreeDec (ExpDec lore), + FreeDec (BodyDec lore), + FreeIn (FParamInfo lore), + FreeIn (LParamInfo lore), + FreeIn (LetDec lore), + FreeIn (Op lore)) => FreeIn (Exp lore) where + freeIn' (DoLoop ctxmerge valmerge form loopbody) = + let (ctxparams, ctxinits) = unzip ctxmerge + (valparams, valinits) = unzip valmerge + bound_here = namesFromList $ M.keys $ + scopeOf form <> + scopeOfFParams (ctxparams ++ valparams) + in fvBind bound_here $ + freeIn' (ctxinits ++ valinits) <> freeIn' form <> + freeIn' (ctxparams ++ valparams) <> freeIn' loopbody + freeIn' e = execState (walkExpM freeWalker e) mempty + +instance (FreeDec (ExpDec lore), + FreeDec (BodyDec lore), + FreeIn (FParamInfo lore), + FreeIn (LParamInfo lore), + FreeIn (LetDec lore), + FreeIn (Op lore)) => FreeIn (Stm lore) where + freeIn' (Let pat (StmAux cs attrs dec) e) = + freeIn' cs <> freeIn' attrs <> + precomputed dec (freeIn' dec <> freeIn' e <> freeIn' pat) + +instance FreeIn (Stm lore) => FreeIn (Stms lore) where + freeIn' = foldMap freeIn' + +instance FreeIn Names where + freeIn' = fvNames + +instance FreeIn Bool where + freeIn' _ = mempty + +instance FreeIn a => FreeIn (Maybe a) where + freeIn' = maybe mempty freeIn' + +instance FreeIn VName where + freeIn' = fvName + +instance FreeIn Ident where + freeIn' = freeIn' . identType + +instance FreeIn SubExp where + freeIn' (Var v) = freeIn' v + freeIn' Constant{} = mempty + +instance FreeIn Space where + freeIn' (ScalarSpace d _) = freeIn' d + freeIn' DefaultSpace = mempty + freeIn' (Space _) = mempty + +instance FreeIn d => FreeIn (ShapeBase d) where + freeIn' = freeIn' . shapeDims + +instance FreeIn d => FreeIn (Ext d) where + freeIn' (Free x) = freeIn' x + freeIn' (Ext _) = mempty + +instance FreeIn shape => FreeIn (TypeBase shape u) where + freeIn' (Array _ shape _) = freeIn' shape + freeIn' (Mem s) = freeIn' s + freeIn' (Prim _) = mempty + +instance FreeIn dec => FreeIn (Param dec) where + freeIn' (Param _ dec) = freeIn' dec + +instance FreeIn dec => FreeIn (PatElemT dec) where + freeIn' (PatElem _ dec) = freeIn' dec + +instance FreeIn (LParamInfo lore) => FreeIn (LoopForm lore) where + freeIn' (ForLoop _ _ bound loop_vars) = freeIn' bound <> freeIn' loop_vars + freeIn' (WhileLoop cond) = freeIn' cond + +instance FreeIn d => FreeIn (DimChange d) where + freeIn' = Data.Foldable.foldMap freeIn' + +instance FreeIn d => FreeIn (DimIndex d) where + freeIn' = Data.Foldable.foldMap freeIn' + +instance FreeIn dec => FreeIn (PatternT dec) where + freeIn' (Pattern context values) = + fvBind bound_here $ freeIn' $ context ++ values + where bound_here = namesFromList $ map patElemName $ context ++ values + +instance FreeIn Certificates where + freeIn' (Certificates cs) = freeIn' cs + +instance FreeIn Attrs where + freeIn' (Attrs _) = mempty + +instance FreeIn dec => FreeIn (StmAux dec) where + freeIn' (StmAux cs attrs dec) = freeIn' cs <> freeIn' attrs <> freeIn' dec + +instance FreeIn a => FreeIn (IfDec a) where + freeIn' (IfDec r _) = freeIn' r + +-- | Either return precomputed free names stored in the attribute, or +-- the freshly computed names. Relies on lazy evaluation to avoid the +-- work. +class FreeIn dec => FreeDec dec where + precomputed :: dec -> FV -> FV + precomputed _ = id + +instance FreeDec () where + +instance (FreeDec a, FreeIn b) => FreeDec (a,b) where + precomputed (a,_) = precomputed a + +instance FreeDec a => FreeDec [a] where + precomputed [] = id + precomputed (a:_) = precomputed a + +instance FreeDec a => FreeDec (Maybe a) where + precomputed Nothing = id + precomputed (Just a) = precomputed a + +-- | The names bound by the bindings immediately in a t'Body'. +boundInBody :: Body lore -> Names +boundInBody = boundByStms . bodyStms + +-- | The names bound by a binding. +boundByStm :: Stm lore -> Names +boundByStm = namesFromList . patternNames . stmPattern + +-- | The names bound by the bindings. +boundByStms :: Stms lore -> Names +boundByStms = foldMap boundByStm + +-- | The names of the lambda parameters plus the index parameter. +boundByLambda :: Lambda lore -> [VName] +boundByLambda lam = map paramName (lambdaParams lam) diff --git a/src/Futhark/IR/Prop/Patterns.hs b/src/Futhark/IR/Prop/Patterns.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/IR/Prop/Patterns.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +-- | Inspecing and modifying t'Pattern's, function parameters and +-- pattern elements. +module Futhark.IR.Prop.Patterns + ( + -- * Function parameters + paramIdent + , paramType + , paramDeclType + -- * Pattern elements + , patElemIdent + , patElemType + , setPatElemLore + , patternElements + , patternIdents + , patternContextIdents + , patternValueIdents + , patternNames + , patternValueNames + , patternContextNames + , patternTypes + , patternValueTypes + , patternSize + -- * Pattern construction + , basicPattern + ) + where + +import Futhark.IR.Syntax +import Futhark.IR.Prop.Types (Typed(..), DeclTyped(..)) + +-- | The 'Type' of a parameter. +paramType :: Typed dec => Param dec -> Type +paramType = typeOf + +-- | The 'DeclType' of a parameter. +paramDeclType :: DeclTyped dec => Param dec -> DeclType +paramDeclType = declTypeOf + +-- | An 'Ident' corresponding to a parameter. +paramIdent :: Typed dec => Param dec -> Ident +paramIdent param = Ident (paramName param) (typeOf param) + +-- | An 'Ident' corresponding to a pattern element. +patElemIdent :: Typed dec => PatElemT dec -> Ident +patElemIdent pelem = Ident (patElemName pelem) (typeOf pelem) + +-- | The type of a name bound by a t'PatElem'. +patElemType :: Typed dec => PatElemT dec -> Type +patElemType = typeOf + +-- | Set the lore of a t'PatElem'. +setPatElemLore :: PatElemT oldattr -> newattr -> PatElemT newattr +setPatElemLore pe x = fmap (const x) pe + +-- | All pattern elements in the pattern - context first, then values. +patternElements :: PatternT dec -> [PatElemT dec] +patternElements pat = patternContextElements pat ++ patternValueElements pat + +-- | Return a list of the 'Ident's bound by the t'Pattern'. +patternIdents :: Typed dec => PatternT dec -> [Ident] +patternIdents pat = patternContextIdents pat ++ patternValueIdents pat + +-- | Return a list of the context 'Ident's bound by the t'Pattern'. +patternContextIdents :: Typed dec => PatternT dec -> [Ident] +patternContextIdents = map patElemIdent . patternContextElements + +-- | Return a list of the value 'Ident's bound by the t'Pattern'. +patternValueIdents :: Typed dec => PatternT dec -> [Ident] +patternValueIdents = map patElemIdent . patternValueElements + +-- | Return a list of the 'Name's bound by the t'Pattern'. +patternNames :: PatternT dec -> [VName] +patternNames = map patElemName . patternElements + +-- | Return a list of the 'Name's bound by the context part of the t'Pattern'. +patternContextNames :: PatternT dec -> [VName] +patternContextNames = map patElemName . patternContextElements + +-- | Return a list of the 'Name's bound by the value part of the t'Pattern'. +patternValueNames :: PatternT dec -> [VName] +patternValueNames = map patElemName . patternValueElements + +-- | Return a list of the typess bound by the pattern. +patternTypes :: Typed dec => PatternT dec -> [Type] +patternTypes = map identType . patternIdents + +-- | Return a list of the typess bound by the value part of the pattern. +patternValueTypes :: Typed dec => PatternT dec -> [Type] +patternValueTypes = map identType . patternValueIdents + +-- | Return the number of names bound by the pattern. +patternSize :: PatternT dec -> Int +patternSize (Pattern context values) = length context + length values + +-- | Create a pattern using 'Type' as the attribute. +basicPattern :: [Ident] -> [Ident] -> PatternT Type +basicPattern context values = + Pattern (map patElem context) (map patElem values) + where patElem (Ident name t) = PatElem name t diff --git a/src/Futhark/IR/Prop/Ranges.hs b/src/Futhark/IR/Prop/Ranges.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/IR/Prop/Ranges.hs @@ -0,0 +1,282 @@ +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +-- | Utility declarations for performing range analysis. The ranges +-- computed here are /local/ (does not take range of subexpressions +-- into account), which is probably not very interesting. See +-- "Futhark.Analysis.Range" for a more comprehensive analysis built on +-- these building blocks. +module Futhark.IR.Prop.Ranges + ( Bound + , KnownBound (..) + , boundToScalExp + , minimumBound + , maximumBound + , Range + , unknownRange + , ScalExpRange + , Ranged + , RangeOf (..) + , RangesOf (..) + , expRanges + , RangedOp (..) + , CanBeRanged (..) + ) + where + +import qualified Data.Kind +import qualified Data.Map.Strict as M + +import Futhark.IR.Prop +import Futhark.IR.Syntax +import qualified Futhark.Analysis.ScalExp as SE +import qualified Futhark.Analysis.AlgSimplify as AS +import Futhark.Transform.Substitute +import Futhark.Transform.Rename +import qualified Futhark.Util.Pretty as PP + +-- | A known bound on a value. +data KnownBound = VarBound VName + -- ^ Has the same bounds as this variable. VERY + -- IMPORTANT: this variable may be an array, so it + -- cannot be immediately translated to a 'SE.ScalExp'. + | MinimumBound KnownBound KnownBound + -- ^ Bounded by the minimum of these two bounds. + | MaximumBound KnownBound KnownBound + -- ^ Bounded by the maximum of these two bounds. + | ScalarBound SE.ScalExp + -- ^ Bounded by this scalar expression. + deriving (Eq, Ord, Show) + +instance Substitute KnownBound where + substituteNames substs (VarBound name) = + VarBound $ substituteNames substs name + substituteNames substs (MinimumBound b1 b2) = + MinimumBound (substituteNames substs b1) (substituteNames substs b2) + substituteNames substs (MaximumBound b1 b2) = + MaximumBound (substituteNames substs b1) (substituteNames substs b2) + substituteNames substs (ScalarBound se) = + ScalarBound $ substituteNames substs se + +instance Rename KnownBound where + rename = substituteRename + +instance FreeIn KnownBound where + freeIn' (VarBound v) = freeIn' v + freeIn' (MinimumBound b1 b2) = freeIn' b1 <> freeIn' b2 + freeIn' (MaximumBound b1 b2) = freeIn' b1 <> freeIn' b2 + freeIn' (ScalarBound e) = freeIn' e + +instance FreeDec KnownBound where + precomputed _ = id + +instance PP.Pretty KnownBound where + ppr (VarBound v) = + PP.text "variable " <> PP.ppr v + ppr (MinimumBound b1 b2) = + PP.text "min" <> PP.parens (PP.ppr b1 <> PP.comma PP.<+> PP.ppr b2) + ppr (MaximumBound b1 b2) = + PP.text "max" <> PP.parens (PP.ppr b1 <> PP.comma PP.<+> PP.ppr b2) + ppr (ScalarBound e) = + PP.ppr e + +-- | Convert the bound to a scalar expression if possible. This is +-- possible for all bounds that do not contain 'VarBound's. +boundToScalExp :: KnownBound -> Maybe SE.ScalExp +boundToScalExp (VarBound _) = Nothing +boundToScalExp (ScalarBound se) = Just se +boundToScalExp (MinimumBound b1 b2) = do + b1' <- boundToScalExp b1 + b2' <- boundToScalExp b2 + return $ SE.MaxMin True [b1', b2'] +boundToScalExp (MaximumBound b1 b2) = do + b1' <- boundToScalExp b1 + b2' <- boundToScalExp b2 + return $ SE.MaxMin False [b1', b2'] + +-- | A possibly undefined bound on a value. +type Bound = Maybe KnownBound + +-- | Construct a 'MinimumBound' from two possibly known bounds. The +-- resulting bound will be unknown unless both of the given 'Bound's +-- are known. This may seem counterintuitive, but it actually makes +-- sense when you consider the task of combining the lower bounds for +-- two different flows of execution (like an @if@ expression). If we +-- only have knowledge about one of the branches, this means that we +-- have no useful information about the combined lower bound, as the +-- other branch may take any value. +minimumBound :: Bound -> Bound -> Bound +minimumBound (Just x) (Just y) = Just $ MinimumBound x y +minimumBound _ _ = Nothing + +-- | Like 'minimumBound', but constructs a 'MaximumBound'. +maximumBound :: Bound -> Bound -> Bound +maximumBound (Just x) (Just y) = Just $ MaximumBound x y +maximumBound _ _ = Nothing + +-- | Upper and lower bound, both inclusive. +type Range = (Bound, Bound) + +-- | A range in which both upper and lower bounds are 'Nothing. +unknownRange :: Range +unknownRange = (Nothing, Nothing) + +-- | The range as a pair of scalar expressions. +type ScalExpRange = (Maybe SE.ScalExp, Maybe SE.ScalExp) + +-- | The lore has embedded range information. Note that it may not be +-- up to date, unless whatever maintains the syntax tree is careful. +type Ranged lore = (ASTLore lore, + RangedOp (Op lore), + RangeOf (LetDec lore), + RangesOf (BodyDec lore)) + +-- | Something that contains range information. +class RangeOf a where + -- | The range of the argument element. + rangeOf :: a -> Range + +instance RangeOf Range where + rangeOf = id + +instance RangeOf dec => RangeOf (PatElemT dec) where + rangeOf = rangeOf . patElemDec + +instance RangeOf SubExp where + rangeOf se = (Just lower, Just upper) + where (lower, upper) = subExpKnownRange se + +-- | Something that contains range information for several things, +-- most notably t'Body' and t'Pattern'. +class RangesOf a where + -- | The ranges of the argument. + rangesOf :: a -> [Range] + +instance RangeOf a => RangesOf [a] where + rangesOf = map rangeOf + +instance RangeOf dec => RangesOf (PatternT dec) where + rangesOf = map rangeOf . patternElements + +instance Ranged lore => RangesOf (Body lore) where + rangesOf = rangesOf . bodyDec + +subExpKnownRange :: SubExp -> (KnownBound, KnownBound) +subExpKnownRange (Var v) = + (VarBound v, + VarBound v) +subExpKnownRange (Constant val) = + (ScalarBound $ SE.Val val, + ScalarBound $ SE.Val val) + +-- | The range of a scalar expression. +scalExpRange :: SE.ScalExp -> Range +scalExpRange se = + (Just $ ScalarBound se, Just $ ScalarBound se) + +primOpRanges :: BasicOp -> [Range] +primOpRanges (SubExp se) = + [rangeOf se] + +primOpRanges (BinOp (Add t _) x y) = + [scalExpRange $ SE.SPlus (SE.subExpToScalExp x $ IntType t) (SE.subExpToScalExp y $ IntType t)] +primOpRanges (BinOp (Sub t _) x y) = + [scalExpRange $ SE.SMinus (SE.subExpToScalExp x $ IntType t) (SE.subExpToScalExp y $ IntType t)] +primOpRanges (BinOp (Mul t _) x y) = + [scalExpRange $ SE.STimes (SE.subExpToScalExp x $ IntType t) (SE.subExpToScalExp y $ IntType t)] +primOpRanges (BinOp (SDiv t) x y) = + [scalExpRange $ SE.SDiv (SE.subExpToScalExp x $ IntType t) (SE.subExpToScalExp y $ IntType t)] + +primOpRanges (ConvOp (SExt from to) x) + | from < to = [rangeOf x] + +primOpRanges (ConvOp (BToI it) _) = + [(Just $ ScalarBound $ SE.Val $ IntValue $ intValue it (0::Int), + Just $ ScalarBound $ SE.Val $ IntValue $ intValue it (1::Int))] + +primOpRanges (Iota n x s Int32) = + [(Just $ ScalarBound x', + Just $ ScalarBound $ x' + (n' - 1) * s')] + where n' = case n of + Var v -> SE.Id v $ IntType Int32 + Constant val -> SE.Val val + x' = case x of + Var v -> SE.Id v $ IntType Int32 + Constant val -> SE.Val val + s' = case s of + Var v -> SE.Id v $ IntType Int32 + Constant val -> SE.Val val +primOpRanges (Replicate _ v) = + [rangeOf v] +primOpRanges (Rearrange _ v) = + [rangeOf $ Var v] +primOpRanges (Copy se) = + [rangeOf $ Var se] +primOpRanges (Index v _) = + [rangeOf $ Var v] +primOpRanges (ArrayLit (e:es) _) = + [(Just lower, Just upper)] + where (e_lower, e_upper) = subExpKnownRange e + (es_lower, es_upper) = unzip $ map subExpKnownRange es + lower = foldl MinimumBound e_lower es_lower + upper = foldl MaximumBound e_upper es_upper +primOpRanges _ = + [unknownRange] + +-- | Ranges of the value parts of the expression. +expRanges :: Ranged lore => + Exp lore -> [Range] +expRanges (BasicOp op) = + primOpRanges op +expRanges (If _ tbranch fbranch _) = + zip + (zipWith minimumBound t_lower f_lower) + (zipWith maximumBound t_upper f_upper) + where (t_lower, t_upper) = unzip $ rangesOf tbranch + (f_lower, f_upper) = unzip $ rangesOf fbranch +expRanges (DoLoop ctxmerge valmerge (ForLoop i Int32 iterations _) body) = + zipWith returnedRange valmerge $ rangesOf body + where bound_in_loop = + namesFromList $ i : map (paramName . fst) (ctxmerge++valmerge) ++ + concatMap (patternNames . stmPattern) (bodyStms body) + + returnedRange mergeparam (lower, upper) = + (returnedBound mergeparam lower, + returnedBound mergeparam upper) + + returnedBound (param, mergeinit) (Just bound) + | paramType param == Prim (IntType Int32), + Just bound' <- boundToScalExp bound, + let se_diff = + AS.simplify (SE.SMinus (SE.Id (paramName param) $ IntType Int32) bound') M.empty, + namesIntersect bound_in_loop $ freeIn se_diff = + Just $ ScalarBound $ SE.SPlus (SE.subExpToScalExp mergeinit $ IntType Int32) $ + SE.STimes se_diff $ SE.MaxMin False + [SE.subExpToScalExp iterations $ IntType Int32, 0] + returnedBound _ _ = Nothing +expRanges (Op ranges) = opRanges ranges +expRanges e = + replicate (expExtTypeSize e) unknownRange + +-- | The class of operations that can produce range information. +class IsOp op => RangedOp op where + opRanges :: op -> [Range] + +instance RangedOp () where + opRanges () = [] + +-- | The class of operations that can be given ranging information. +-- This is a somewhat subtle concept that is only used in the +-- simplifier and when using "lore adapters". +class RangedOp (OpWithRanges op) => + CanBeRanged op where + type OpWithRanges op :: Data.Kind.Type + removeOpRanges :: OpWithRanges op -> op + addOpRanges :: op -> OpWithRanges op + +instance CanBeRanged () where + type OpWithRanges () = () + removeOpRanges = id + addOpRanges = id diff --git a/src/Futhark/IR/Prop/Rearrange.hs b/src/Futhark/IR/Prop/Rearrange.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/IR/Prop/Rearrange.hs @@ -0,0 +1,108 @@ +-- | A rearrangement is a generalisation of transposition, where the +-- dimensions are arbitrarily permuted. +module Futhark.IR.Prop.Rearrange + ( rearrangeShape + , rearrangeInverse + , rearrangeReach + , rearrangeCompose + , isPermutationOf + , transposeIndex + , isMapTranspose + ) where + +import Data.List (sortOn, tails) + +import Futhark.Util + +-- | Calculate the given permutation of the list. It is an error if +-- the permutation goes out of bounds. +rearrangeShape :: [Int] -> [a] -> [a] +rearrangeShape perm l = map pick perm + where pick i + | 0 <= i, i < n = l!!i + | otherwise = + error $ show perm ++ " is not a valid permutation for input." + n = length l + +-- | Produce the inverse permutation. +rearrangeInverse :: [Int] -> [Int] +rearrangeInverse perm = map snd $ sortOn fst $ zip perm [0..] + +-- | Return the first dimension not affected by the permutation. For +-- example, the permutation @[1,0,2]@ would return @2@. +rearrangeReach :: [Int] -> Int +rearrangeReach perm = case dropWhile (uncurry (/=)) $ zip (tails perm) (tails [0..n-1]) of + [] -> n + 1 + (perm',_):_ -> n - length perm' + where n = length perm + +-- | Compose two permutations, with the second given permutation being +-- applied first. +rearrangeCompose :: [Int] -> [Int] -> [Int] +rearrangeCompose = rearrangeShape + +-- | Check whether the first list is a permutation of the second, and +-- if so, return the permutation. This will also find identity +-- permutations (i.e. the lists are the same) The implementation is +-- naive and slow. +isPermutationOf :: Eq a => [a] -> [a] -> Maybe [Int] +isPermutationOf l1 l2 = + case mapAccumLM (pick 0) (map Just l2) l1 of + Just (l2', perm) + | all (==Nothing) l2' -> Just perm + _ -> Nothing + where pick :: Eq a => Int -> [Maybe a] -> a -> Maybe ([Maybe a], Int) + pick _ [] _ = Nothing + pick i (x:xs) y + | Just y == x = Just (Nothing : xs, i) + | otherwise = do + (xs', v) <- pick (i+1) xs y + return (x : xs', v) + +-- | If @l@ is an index into the array @a@, then @transposeIndex k n +-- l@ is an index to the same element in the array @transposeArray k n +-- a@. +transposeIndex :: Int -> Int -> [a] -> [a] +transposeIndex k n l + | k + n >= length l = + let n' = ((k + n) `mod` length l)-k + in transposeIndex k n' l + | n < 0, + (pre,needle:end) <- splitAt k l, + (beg,mid) <- splitAt (length pre+n) pre = + beg ++ [needle] ++ mid ++ end + | (beg,needle:post) <- splitAt k l, + (mid,end) <- splitAt n post = + beg ++ mid ++ [needle] ++ end + | otherwise = l + +-- | If @perm@ is conceptually a map of a transposition, +-- @isMapTranspose perm@ returns the number of dimensions being mapped +-- and the number dimension being transposed. For example, we can +-- consider the permutation @[0,1,4,5,2,3]@ as a map of a transpose, +-- by considering dimensions @[0,1]@, @[4,5]@, and @[2,3]@ as single +-- dimensions each. +-- +-- If the input is not a valid permutation, then the result is +-- undefined. +isMapTranspose :: [Int] -> Maybe (Int, Int, Int) +isMapTranspose perm + | posttrans == [length mapped..length mapped+length posttrans-1], + not $ null pretrans, not $ null posttrans = + Just (length mapped, length pretrans, length posttrans) + | otherwise = + Nothing + where (mapped, notmapped) = findIncreasingFrom 0 perm + (pretrans, posttrans) = findTransposed notmapped + + findIncreasingFrom x (i:is) + | i == x = + let (js, ps) = findIncreasingFrom (x+1) is + in (i : js, ps) + findIncreasingFrom _ is = + ([], is) + + findTransposed [] = + ([], []) + findTransposed (i:is) = + findIncreasingFrom i (i:is) diff --git a/src/Futhark/IR/Prop/Reshape.hs b/src/Futhark/IR/Prop/Reshape.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/IR/Prop/Reshape.hs @@ -0,0 +1,177 @@ +-- | Facilities for creating, inspecting, and simplifying reshape and +-- coercion operations. +module Futhark.IR.Prop.Reshape + ( + -- * Basic tools + newDim + , newDims + , newShape + + -- * Construction + , shapeCoerce + , repeatShapes + + -- * Execution + , reshapeOuter + , reshapeInner + , repeatDims + + -- * Inspection + , shapeCoercion + + -- * Simplification + , fuseReshape + , informReshape + + -- * Shape calculations + , reshapeIndex + , flattenIndex + , unflattenIndex + , sliceSizes + ) + where + +import Data.Foldable + +import Prelude hiding (sum, product, quot) + +import Futhark.IR.Prop.Types +import Futhark.IR.Syntax +import Futhark.Util.IntegralExp + +-- | The new dimension. +newDim :: DimChange d -> d +newDim (DimCoercion se) = se +newDim (DimNew se) = se + +-- | The new dimensions resulting from a reshape operation. +newDims :: ShapeChange d -> [d] +newDims = map newDim + +-- | The new shape resulting from a reshape operation. +newShape :: ShapeChange SubExp -> Shape +newShape = Shape . newDims + +-- | Construct a 'Reshape' where all dimension changes are +-- 'DimCoercion's. +shapeCoerce :: [SubExp] -> VName -> Exp lore +shapeCoerce newdims arr = + BasicOp $ Reshape (map DimCoercion newdims) arr + +-- | Construct a pair suitable for a 'Repeat'. +repeatShapes :: [Shape] -> Type -> ([Shape], Shape) +repeatShapes shapes t = + case splitAt t_rank shapes of + (outer_shapes, [inner_shape]) -> + (outer_shapes, inner_shape) + _ -> + (shapes ++ replicate (length shapes - t_rank) (Shape []), Shape []) + where t_rank = arrayRank t + +-- | Modify the shape of an array type as 'Repeat' would do +repeatDims :: [Shape] -> Shape -> Type -> Type +repeatDims shape innershape = modifyArrayShape repeatDims' + where repeatDims' (Shape ds) = + Shape $ concat (zipWith (++) (map shapeDims shape) (map pure ds)) ++ + shapeDims innershape + +-- | @reshapeOuter newshape n oldshape@ returns a 'Reshape' expression +-- that replaces the outer @n@ dimensions of @oldshape@ with @newshape@. +reshapeOuter :: ShapeChange SubExp -> Int -> Shape -> ShapeChange SubExp +reshapeOuter newshape n oldshape = + newshape ++ map coercion_or_new (drop n (shapeDims oldshape)) + where coercion_or_new + | length newshape == n = DimCoercion + | otherwise = DimNew + +-- | @reshapeInner newshape n oldshape@ returns a 'Reshape' expression +-- that replaces the inner @m-n@ dimensions (where @m@ is the rank of +-- @oldshape@) of @src@ with @newshape@. +reshapeInner :: ShapeChange SubExp -> Int -> Shape -> ShapeChange SubExp +reshapeInner newshape n oldshape = + map coercion_or_new (take n (shapeDims oldshape)) ++ newshape + where coercion_or_new + | length newshape == m-n = DimCoercion + | otherwise = DimNew + m = shapeRank oldshape + +-- | If the shape change is nothing but shape coercions, return the new dimensions. Otherwise, return +-- 'Nothing'. +shapeCoercion :: ShapeChange d -> Maybe [d] +shapeCoercion = mapM dimCoercion + where dimCoercion (DimCoercion d) = Just d + dimCoercion (DimNew _) = Nothing + +-- | @fuseReshape s1 s2@ creates a new 'ShapeChange' that is +-- semantically the same as first applying @s1@ and then @s2@. This +-- may take advantage of properties of 'DimCoercion' versus 'DimNew' +-- to preserve information. +fuseReshape :: Eq d => ShapeChange d -> ShapeChange d -> ShapeChange d +fuseReshape s1 s2 + | length s1 == length s2 = + zipWith comb s1 s2 + where comb (DimNew _) (DimCoercion d2) = + DimNew d2 + comb (DimCoercion d1) (DimNew d2) + | d1 == d2 = DimCoercion d2 + | otherwise = DimNew d2 + comb _ d2 = + d2 +-- TODO: intelligently handle case where s1 is a prefix of s2. +fuseReshape _ s2 = s2 + +-- | Given concrete information about the shape of the source array, +-- convert some 'DimNew's into 'DimCoercion's. +informReshape :: Eq d => [d] -> ShapeChange d -> ShapeChange d +informReshape shape sc + | length shape == length sc = + zipWith inform shape sc + where inform d1 (DimNew d2) + | d1 == d2 = DimCoercion d2 + inform _ dc = + dc +informReshape _ sc = sc + +-- | @reshapeIndex to_dims from_dims is@ transforms the index list +-- @is@ (which is into an array of shape @from_dims@) into an index +-- list @is'@, which is into an array of shape @to_dims@. @is@ must +-- have the same length as @from_dims@, and @is'@ will have the same +-- length as @to_dims@. +reshapeIndex :: IntegralExp num => + [num] -> [num] -> [num] -> [num] +reshapeIndex to_dims from_dims is = + unflattenIndex to_dims $ flattenIndex from_dims is + +-- | @unflattenIndex dims i@ computes a list of indices into an array +-- with dimension @dims@ given the flat index @i@. The resulting list +-- will have the same size as @dims@. +unflattenIndex :: IntegralExp num => + [num] -> num -> [num] +unflattenIndex = unflattenIndexFromSlices . drop 1 . sliceSizes + +unflattenIndexFromSlices :: IntegralExp num => + [num] -> num -> [num] +unflattenIndexFromSlices [] _ = [] +unflattenIndexFromSlices (size : slices) i = + (i `quot` size) : unflattenIndexFromSlices slices (i - (i `quot` size) * size) + +-- | @flattenIndex dims is@ computes the flat index of @is@ into an +-- array with dimensions @dims@. The length of @dims@ and @is@ must +-- be the same. +flattenIndex :: IntegralExp num => + [num] -> [num] -> num +flattenIndex dims is = + sum $ zipWith (*) is slicesizes + where slicesizes = drop 1 $ sliceSizes dims + +-- | Given a length @n@ list of dimensions @dims@, @sizeSizes dims@ +-- will compute a length @n+1@ list of the size of each possible array +-- slice. The first element of this list will be the product of +-- @dims@, and the last element will be 1. +sliceSizes :: IntegralExp num => + [num] -> [num] +sliceSizes [] = [1] +sliceSizes (n:ns) = + product (n : ns) : sliceSizes ns + +{- HLINT ignore sliceSizes -} diff --git a/src/Futhark/IR/Prop/Scope.hs b/src/Futhark/IR/Prop/Scope.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/IR/Prop/Scope.hs @@ -0,0 +1,227 @@ +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE Trustworthy #-} +-- | The core Futhark AST does not contain type information when we +-- use a variable. Therefore, most transformations expect to be able +-- to access some kind of symbol table that maps names to their types. +-- +-- This module defines the concept of a type environment as a mapping +-- from variable names to 'NameInfo's. Convenience facilities are +-- also provided to communicate that some monad or applicative functor +-- maintains type information. +module Futhark.IR.Prop.Scope + ( HasScope (..) + , NameInfo (..) + , LocalScope (..) + , Scope + , Scoped(..) + , inScopeOf + , scopeOfLParams + , scopeOfFParams + , scopeOfPattern + , scopeOfPatElem + + , SameScope + , castScope + + -- * Extended type environment + , ExtendedScope + , extendedScope + ) where + +import Control.Monad.Except +import Control.Monad.Reader +import qualified Control.Monad.RWS.Strict +import qualified Control.Monad.RWS.Lazy +import qualified Data.Map.Strict as M + +import Futhark.IR.Decorations +import Futhark.IR.Syntax +import Futhark.IR.Prop.Types +import Futhark.IR.Prop.Patterns +import Futhark.IR.Pretty () + +-- | How some name in scope was bound. +data NameInfo lore = LetName (LetDec lore) + | FParamName (FParamInfo lore) + | LParamName (LParamInfo lore) + | IndexName IntType + +deriving instance Decorations lore => Show (NameInfo lore) + +instance Decorations lore => Typed (NameInfo lore) where + typeOf (LetName dec) = typeOf dec + typeOf (FParamName dec) = typeOf dec + typeOf (LParamName dec) = typeOf dec + typeOf (IndexName it) = Prim $ IntType it + +-- | A scope is a mapping from variable names to information about +-- that name. +type Scope lore = M.Map VName (NameInfo lore) + +-- | The class of applicative functors (or more common in practice: +-- monads) that permit the lookup of variable types. A default method +-- for 'lookupType' exists, which is sufficient (if not always +-- maximally efficient, and using 'error' to fail) when 'askScope' +-- is defined. +class (Applicative m, Decorations lore) => HasScope lore m | m -> lore where + -- | Return the type of the given variable, or fail if it is not in + -- the type environment. + lookupType :: VName -> m Type + lookupType = fmap typeOf . lookupInfo + + -- | Return the info of the given variable, or fail if it is not in + -- the type environment. + lookupInfo :: VName -> m (NameInfo lore) + lookupInfo name = + asksScope (M.findWithDefault notFound name) + where notFound = + error $ "Scope.lookupInfo: Name " ++ pretty name ++ + " not found in type environment." + + -- | Return the type environment contained in the applicative + -- functor. + askScope :: m (Scope lore) + + -- | Return the result of applying some function to the type + -- environment. + asksScope :: (Scope lore -> a) -> m a + asksScope f = f <$> askScope + +instance (Applicative m, Monad m, Decorations lore) => + HasScope lore (ReaderT (Scope lore) m) where + askScope = ask + +instance (Monad m, HasScope lore m) => HasScope lore (ExceptT e m) where + askScope = lift askScope + +instance (Applicative m, Monad m, Monoid w, Decorations lore) => + HasScope lore (Control.Monad.RWS.Strict.RWST (Scope lore) w s m) where + askScope = ask + +instance (Applicative m, Monad m, Monoid w, Decorations lore) => + HasScope lore (Control.Monad.RWS.Lazy.RWST (Scope lore) w s m) where + askScope = ask + +-- | The class of monads that not only provide a 'Scope', but also +-- the ability to locally extend it. A 'Reader' containing a +-- 'Scope' is the prototypical example of such a monad. +class (HasScope lore m, Monad m) => LocalScope lore m where + -- | Run a computation with an extended type environment. Note that + -- this is intended to *add* to the current type environment, it + -- does not replace it. + localScope :: Scope lore -> m a -> m a + +instance (Monad m, LocalScope lore m) => LocalScope lore (ExceptT e m) where + localScope = mapExceptT . localScope + +instance (Applicative m, Monad m, Decorations lore) => + LocalScope lore (ReaderT (Scope lore) m) where + localScope = local . M.union + +instance (Applicative m, Monad m, Monoid w, Decorations lore) => + LocalScope lore (Control.Monad.RWS.Strict.RWST (Scope lore) w s m) where + localScope = local . M.union + +instance (Applicative m, Monad m, Monoid w, Decorations lore) => + LocalScope lore (Control.Monad.RWS.Lazy.RWST (Scope lore) w s m) where + localScope = local . M.union + +-- | The class of things that can provide a scope. There is no +-- overarching rule for what this means. For a 'Stm', it is the +-- corresponding pattern. For a t'Lambda', is is the parameters. +class Scoped lore a | a -> lore where + scopeOf :: a -> Scope lore + +-- | Extend the monadic scope with the 'scopeOf' the given value. +inScopeOf :: (Scoped lore a, LocalScope lore m) => a -> m b -> m b +inScopeOf = localScope . scopeOf + +instance Scoped lore a => Scoped lore [a] where + scopeOf = mconcat . map scopeOf + +instance Scoped lore (Stms lore) where + scopeOf = foldMap scopeOf + +instance Scoped lore (Stm lore) where + scopeOf = scopeOfPattern . stmPattern + +instance Scoped lore (FunDef lore) where + scopeOf = scopeOfFParams . funDefParams + +instance Scoped lore (VName, NameInfo lore) where + scopeOf = uncurry M.singleton + +instance Scoped lore (LoopForm lore) where + scopeOf (WhileLoop _) = mempty + scopeOf (ForLoop i it _ xs) = + M.insert i (IndexName it) $ scopeOfLParams (map fst xs) + +-- | The scope of a pattern. +scopeOfPattern :: LetDec lore ~ dec => PatternT dec -> Scope lore +scopeOfPattern = + mconcat . map scopeOfPatElem . patternElements + +-- | The scope of a pattern element. +scopeOfPatElem :: LetDec lore ~ dec => PatElemT dec -> Scope lore +scopeOfPatElem (PatElem name dec) = M.singleton name $ LetName dec + +-- | The scope of some lambda parameters. +scopeOfLParams :: LParamInfo lore ~ dec => + [Param dec] -> Scope lore +scopeOfLParams = M.fromList . map f + where f param = (paramName param, LParamName $ paramDec param) + +-- | The scope of some function or loop parameters. +scopeOfFParams :: FParamInfo lore ~ dec => + [Param dec] -> Scope lore +scopeOfFParams = M.fromList . map f + where f param = (paramName param, FParamName $ paramDec param) + +instance Scoped lore (Lambda lore) where + scopeOf lam = scopeOfLParams $ lambdaParams lam + +-- | A constraint that indicates two lores have the same 'NameInfo' +-- representation. +type SameScope lore1 lore2 = (LetDec lore1 ~ LetDec lore2, + FParamInfo lore1 ~ FParamInfo lore2, + LParamInfo lore1 ~ LParamInfo lore2) + +-- | If two scopes are really the same, then you can convert one to +-- the other. +castScope :: SameScope fromlore tolore => + Scope fromlore -> Scope tolore +castScope = M.map castNameInfo + +castNameInfo :: SameScope fromlore tolore => + NameInfo fromlore -> NameInfo tolore +castNameInfo (LetName dec) = LetName dec +castNameInfo (FParamName dec) = FParamName dec +castNameInfo (LParamName dec) = LParamName dec +castNameInfo (IndexName it) = IndexName it + +-- | A monad transformer that carries around an extended 'Scope'. +-- Its 'lookupType' method will first look in the extended 'Scope', +-- and then use the 'lookupType' method of the underlying monad. +newtype ExtendedScope lore m a = ExtendedScope (ReaderT (Scope lore) m a) + deriving (Functor, Applicative, Monad, + MonadReader (Scope lore)) + +instance (HasScope lore m, Monad m) => + HasScope lore (ExtendedScope lore m) where + lookupType name = do + res <- asks $ fmap typeOf . M.lookup name + maybe (ExtendedScope $ lift $ lookupType name) return res + askScope = asks M.union <*> ExtendedScope (lift askScope) + +-- | Run a computation in the extended type environment. +extendedScope :: ExtendedScope lore m a + -> Scope lore + -> m a +extendedScope (ExtendedScope m) = runReaderT m diff --git a/src/Futhark/IR/Prop/TypeOf.hs b/src/Futhark/IR/Prop/TypeOf.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/IR/Prop/TypeOf.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +-- | This module provides facilities for obtaining the types of +-- various Futhark constructs. Typically, you will need to execute +-- these in a context where type information is available as a +-- 'Scope'; usually by using a monad that is an instance of +-- 'HasScope'. The information is returned as a list of 'ExtType' +-- values - one for each of the values the Futhark construct returns. +-- Some constructs (such as subexpressions) can produce only a single +-- value, and their typing functions hence do not return a list. +-- +-- Some representations may have more specialised facilities enabling +-- even more information - for example, +-- "Futhark.IR.Mem" exposes functionality for +-- also obtaining information about the storage location of results. +module Futhark.IR.Prop.TypeOf + ( + expExtType + , expExtTypeSize + , subExpType + , primOpType + , mapType + + -- * Return type + , module Futhark.IR.RetType + -- * Type environment + , module Futhark.IR.Prop.Scope + + -- * Extensibility + , TypedOp(..) + ) + where + +import Data.Maybe + +import Futhark.IR.Syntax +import Futhark.IR.Prop.Reshape +import Futhark.IR.Prop.Types +import Futhark.IR.Prop.Patterns +import Futhark.IR.Prop.Constants +import Futhark.IR.RetType +import Futhark.IR.Prop.Scope + +-- | The type of a subexpression. +subExpType :: HasScope t m => SubExp -> m Type +subExpType (Constant val) = pure $ Prim $ primValueType val +subExpType (Var name) = lookupType name + +-- | @mapType f arrts@ wraps each element in the return type of @f@ in +-- an array with size equal to the outermost dimension of the first +-- element of @arrts@. +mapType :: SubExp -> Lambda lore -> [Type] +mapType outersize f = [ arrayOf t (Shape [outersize]) NoUniqueness + | t <- lambdaReturnType f ] + +-- | The type of a primitive operation. +primOpType :: HasScope lore m => BasicOp -> m [Type] +primOpType (SubExp se) = + pure <$> subExpType se +primOpType (Opaque se) = + pure <$> subExpType se +primOpType (ArrayLit es rt) = + pure [arrayOf rt (Shape [n]) NoUniqueness] + where n = Constant (value (length es)) +primOpType (BinOp bop _ _) = + pure [Prim $ binOpType bop] +primOpType (UnOp _ x) = + pure <$> subExpType x +primOpType CmpOp{} = + pure [Prim Bool] +primOpType (ConvOp conv _) = + pure [Prim $ snd $ convOpType conv] +primOpType (Index ident slice) = + result <$> lookupType ident + where result t = [Prim (elemType t) `arrayOfShape` shape] + shape = Shape $ mapMaybe dimSize slice + dimSize (DimSlice _ d _) = Just d + dimSize DimFix{} = Nothing +primOpType (Update src _ _) = + pure <$> lookupType src +primOpType (Iota n _ _ et) = + pure [arrayOf (Prim (IntType et)) (Shape [n]) NoUniqueness] +primOpType (Replicate (Shape []) e) = + pure <$> subExpType e +primOpType (Repeat shape innershape v) = + pure . repeatDims shape innershape <$> lookupType v +primOpType (Replicate shape e) = + pure . flip arrayOfShape shape <$> subExpType e +primOpType (Scratch t shape) = + pure [arrayOf (Prim t) (Shape shape) NoUniqueness] +primOpType (Reshape [] e) = + result <$> lookupType e + where result t = [Prim $ elemType t] +primOpType (Reshape shape e) = + result <$> lookupType e + where result t = [t `setArrayShape` newShape shape] +primOpType (Rearrange perm e) = + result <$> lookupType e + where result t = [rearrangeType perm t] +primOpType (Rotate _ e) = + pure <$> lookupType e +primOpType (Concat i x _ ressize) = + result <$> lookupType x + where result xt = [setDimSize i xt ressize] +primOpType (Copy v) = + pure <$> lookupType v +primOpType (Manifest _ v) = + pure <$> lookupType v +primOpType Assert{} = + pure [Prim Cert] + +-- | The type of an expression. +expExtType :: (HasScope lore m, TypedOp (Op lore)) => + Exp lore -> m [ExtType] +expExtType (Apply _ _ rt _) = pure $ map (fromDecl . declExtTypeOf) rt +expExtType (If _ _ _ rt) = pure $ map extTypeOf $ ifReturns rt +expExtType (DoLoop ctxmerge valmerge _ _) = + pure $ loopExtType (map (paramIdent . fst) ctxmerge) (map (paramIdent . fst) valmerge) +expExtType (BasicOp op) = staticShapes <$> primOpType op +expExtType (Op op) = opType op + +-- | The number of values returned by an expression. +expExtTypeSize :: (Decorations lore, TypedOp (Op lore)) => + Exp lore -> Int +expExtTypeSize = length . feelBad . expExtType + +-- FIXME, this is a horrible quick hack. +newtype FeelBad lore a = FeelBad { feelBad :: a } + +instance Functor (FeelBad lore) where + fmap f = FeelBad . f . feelBad + +instance Applicative (FeelBad lore) where + pure = FeelBad + f <*> x = FeelBad $ feelBad f $ feelBad x + +instance Decorations lore => HasScope lore (FeelBad lore) where + lookupType = const $ pure $ Prim $ IntType Int32 + askScope = pure mempty + +-- | Given the context and value merge parameters of a Futhark @loop@, +-- produce the return type. +loopExtType :: [Ident] -> [Ident] -> [ExtType] +loopExtType ctx val = + existentialiseExtTypes inaccessible $ staticShapes $ map identType val + where inaccessible = map identName ctx + +-- | Any operation must define an instance of this class, which +-- describes the type of the operation (at the value level). +class TypedOp op where + opType :: HasScope t m => op -> m [ExtType] + +instance TypedOp () where + opType () = pure [] diff --git a/src/Futhark/IR/Prop/Types.hs b/src/Futhark/IR/Prop/Types.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/IR/Prop/Types.hs @@ -0,0 +1,550 @@ +{-# LANGUAGE FlexibleContexts, FlexibleInstances #-} +-- | Functions for inspecting and constructing various types. +module Futhark.IR.Prop.Types + ( + rankShaped + , arrayRank + , arrayShape + , modifyArrayShape + , setArrayShape + , existential + , uniqueness + , unique + , staticShapes + , staticShapes1 + , primType + + , arrayOf + , arrayOfRow + , arrayOfShape + , setOuterSize + , setDimSize + , setOuterDim + , setDim + , setArrayDims + , peelArray + , stripArray + , arrayDims + , arrayExtDims + , shapeSize + , arraySize + , arraysSize + , rowType + , elemType + + , transposeType + , rearrangeType + + , diet + + , subtypeOf + , subtypesOf + + , toDecl + , fromDecl + + , isExt + , extractShapeContext + , shapeContext + , hasStaticShape + , generaliseExtTypes + , existentialiseExtTypes + , shapeMapping + , shapeExtMapping + + -- * Abbreviations + , int8, int16, int32, int64 + , float32, float64 + + -- * The Typed typeclass + , Typed (..) + , DeclTyped (..) + , ExtTyped (..) + , DeclExtTyped (..) + , SetType (..) + , FixExt (..) + ) + where + +import Control.Monad.State +import Data.Maybe +import Data.List (elemIndex, foldl') +import qualified Data.Set as S +import qualified Data.Map.Strict as M + +import Futhark.IR.Syntax.Core +import Futhark.IR.Prop.Constants +import Futhark.IR.Prop.Rearrange + +-- | Remove shape information from a type. +rankShaped :: ArrayShape shape => TypeBase shape u -> TypeBase Rank u +rankShaped (Array et sz u) = Array et (Rank $ shapeRank sz) u +rankShaped (Prim et) = Prim et +rankShaped (Mem space) = Mem space + +-- | Return the dimensionality of a type. For non-arrays, this is +-- zero. For a one-dimensional array it is one, for a two-dimensional +-- it is two, and so forth. +arrayRank :: ArrayShape shape => TypeBase shape u -> Int +arrayRank = shapeRank . arrayShape + +-- | Return the shape of a type - for non-arrays, this is the +-- 'mempty'. +arrayShape :: ArrayShape shape => TypeBase shape u -> shape +arrayShape (Array _ ds _) = ds +arrayShape _ = mempty + +-- | Modify the shape of an array - for non-arrays, this does nothing. +modifyArrayShape :: ArrayShape newshape => + (oldshape -> newshape) + -> TypeBase oldshape u + -> TypeBase newshape u +modifyArrayShape f (Array t ds u) + | shapeRank ds' == 0 = Prim t + | otherwise = Array t (f ds) u + where ds' = f ds +modifyArrayShape _ (Prim t) = Prim t +modifyArrayShape _ (Mem space) = Mem space + +-- | Set the shape of an array. If the given type is not an +-- array, return the type unchanged. +setArrayShape :: ArrayShape newshape => + TypeBase oldshape u + -> newshape + -> TypeBase newshape u +setArrayShape t ds = modifyArrayShape (const ds) t + +-- | True if the given type has a dimension that is existentially sized. +existential :: ExtType -> Bool +existential = any ext . shapeDims . arrayShape + where ext (Ext _) = True + ext (Free _) = False + +-- | Return the uniqueness of a type. +uniqueness :: TypeBase shape Uniqueness -> Uniqueness +uniqueness (Array _ _ u) = u +uniqueness _ = Nonunique + +-- | @unique t@ is 'True' if the type of the argument is unique. +unique :: TypeBase shape Uniqueness -> Bool +unique = (==Unique) . uniqueness + +-- | Convert types with non-existential shapes to types with +-- non-existential shapes. Only the representation is changed, so all +-- the shapes will be 'Free'. +staticShapes :: [TypeBase Shape u] -> [TypeBase ExtShape u] +staticShapes = map staticShapes1 + +-- | As 'staticShapes', but on a single type. +staticShapes1 :: TypeBase Shape u -> TypeBase ExtShape u +staticShapes1 (Prim bt) = + Prim bt +staticShapes1 (Array bt (Shape shape) u) = + Array bt (Shape $ map Free shape) u +staticShapes1 (Mem space) = + Mem space + +-- | @arrayOf t s u@ constructs an array type. The convenience +-- compared to using the 'Array' constructor directly is that @t@ can +-- itself be an array. If @t@ is an @n@-dimensional array, and @s@ is +-- a list of length @n@, the resulting type is of an @n+m@ dimensions. +-- The uniqueness of the new array will be @u@, no matter the +-- uniqueness of @t@. If the shape @s@ has rank 0, then the @t@ will +-- be returned, although if it is an array, with the uniqueness +-- changed to @u@. +arrayOf :: ArrayShape shape => + TypeBase shape u_unused -> shape -> u -> TypeBase shape u +arrayOf (Array et size1 _) size2 u = + Array et (size2 <> size1) u +arrayOf (Prim et) s _ + | 0 <- shapeRank s = Prim et +arrayOf (Prim et) size u = + Array et size u +arrayOf Mem{} _ _ = + error "arrayOf Mem" + +-- | Construct an array whose rows are the given type, and the outer +-- size is the given dimension. This is just a convenient wrapper +-- around 'arrayOf'. +arrayOfRow :: ArrayShape (ShapeBase d) => + TypeBase (ShapeBase d) NoUniqueness + -> d + -> TypeBase (ShapeBase d) NoUniqueness +arrayOfRow t size = arrayOf t (Shape [size]) NoUniqueness + +-- | Construct an array whose rows are the given type, and the outer +-- size is the given t'Shape'. This is just a convenient wrapper +-- around 'arrayOf'. +arrayOfShape :: Type -> Shape -> Type +arrayOfShape t shape = arrayOf t shape NoUniqueness + +-- | Set the dimensions of an array. If the given type is not an +-- array, return the type unchanged. +setArrayDims :: TypeBase oldshape u -> [SubExp] -> TypeBase Shape u +setArrayDims t dims = t `setArrayShape` Shape dims + +-- | Replace the size of the outermost dimension of an array. If the +-- given type is not an array, it is returned unchanged. +setOuterSize :: ArrayShape (ShapeBase d) => + TypeBase (ShapeBase d) u -> d -> TypeBase (ShapeBase d) u +setOuterSize = setDimSize 0 + +-- | Replace the size of the given dimension of an array. If the +-- given type is not an array, it is returned unchanged. +setDimSize :: ArrayShape (ShapeBase d) => + Int -> TypeBase (ShapeBase d) u -> d -> TypeBase (ShapeBase d) u +setDimSize i t e = t `setArrayShape` setDim i (arrayShape t) e + +-- | Replace the outermost dimension of an array shape. +setOuterDim :: ShapeBase d -> d -> ShapeBase d +setOuterDim = setDim 0 + +-- | Replace the specified dimension of an array shape. +setDim :: Int -> ShapeBase d -> d -> ShapeBase d +setDim i (Shape ds) e = Shape $ take i ds ++ e : drop (i+1) ds + +-- | @peelArray n t@ returns the type resulting from peeling the first +-- @n@ array dimensions from @t@. Returns @Nothing@ if @t@ has less +-- than @n@ dimensions. +peelArray :: ArrayShape shape => + Int -> TypeBase shape u -> Maybe (TypeBase shape u) +peelArray 0 t = Just t +peelArray n (Array et shape u) + | shapeRank shape == n = Just $ Prim et + | shapeRank shape > n = Just $ Array et (stripDims n shape) u +peelArray _ _ = Nothing + +-- | @stripArray n t@ removes the @n@ outermost layers of the array. +-- Essentially, it is the type of indexing an array of type @t@ with +-- @n@ indexes. +stripArray :: ArrayShape shape => Int -> TypeBase shape u -> TypeBase shape u +stripArray n (Array et shape u) + | n < shapeRank shape = Array et (stripDims n shape) u + | otherwise = Prim et +stripArray _ t = t + +-- | Return the size of the given dimension. If the dimension does +-- not exist, the zero constant is returned. +shapeSize :: Int -> Shape -> SubExp +shapeSize i shape = case drop i $ shapeDims shape of + e : _ -> e + [] -> constant (0 :: Int32) + +-- | Return the dimensions of a type - for non-arrays, this is the +-- empty list. +arrayDims :: TypeBase Shape u -> [SubExp] +arrayDims = shapeDims . arrayShape + +-- | Return the existential dimensions of a type - for non-arrays, +-- this is the empty list. +arrayExtDims :: TypeBase ExtShape u -> [ExtSize] +arrayExtDims = shapeDims . arrayShape + +-- | Return the size of the given dimension. If the dimension does +-- not exist, the zero constant is returned. +arraySize :: Int -> TypeBase Shape u -> SubExp +arraySize i = shapeSize i . arrayShape + +-- | Return the size of the given dimension in the first element of +-- the given type list. If the dimension does not exist, or no types +-- are given, the zero constant is returned. +arraysSize :: Int -> [TypeBase Shape u] -> SubExp +arraysSize _ [] = constant (0 :: Int32) +arraysSize i (t:_) = arraySize i t + +-- | Return the immediate row-type of an array. For @[[int]]@, this +-- would be @[int]@. +rowType :: ArrayShape shape => TypeBase shape u -> TypeBase shape u +rowType = stripArray 1 + +-- | A type is a primitive type if it is not an array or memory block. +primType :: TypeBase shape u -> Bool +primType Array{} = False +primType Mem{} = False +primType _ = True + +-- | Returns the bottommost type of an array. For @[[int]]@, this +-- would be @int@. If the given type is not an array, it is returned. +elemType :: TypeBase shape u -> PrimType +elemType (Array t _ _) = t +elemType (Prim t) = t +elemType Mem{} = error "elemType Mem" + +-- | Swap the two outer dimensions of the type. +transposeType :: Type -> Type +transposeType = rearrangeType [1,0] + +-- | Rearrange the dimensions of the type. If the length of the +-- permutation does not match the rank of the type, the permutation +-- will be extended with identity. +rearrangeType :: [Int] -> Type -> Type +rearrangeType perm t = + t `setArrayShape` Shape (rearrangeShape perm' $ arrayDims t) + where perm' = perm ++ [length perm .. arrayRank t - 1] + +-- | @diet t@ returns a description of how a function parameter of +-- type @t@ might consume its argument. +diet :: TypeBase shape Uniqueness -> Diet +diet (Prim _) = ObservePrim +diet (Array _ _ Unique) = Consume +diet (Array _ _ Nonunique) = Observe +diet Mem{} = Observe + +-- | @x \`subtypeOf\` y@ is true if @x@ is a subtype of @y@ (or equal to +-- @y@), meaning @x@ is valid whenever @y@ is. +subtypeOf :: (Ord u, ArrayShape shape) => + TypeBase shape u + -> TypeBase shape u + -> Bool +subtypeOf (Array t1 shape1 u1) (Array t2 shape2 u2) = + u2 <= u1 && + t1 == t2 && + shape1 `subShapeOf` shape2 +subtypeOf (Prim t1) (Prim t2) = t1 == t2 +subtypeOf (Mem space1) (Mem space2) = space1 == space2 +subtypeOf _ _ = False + +-- | @xs \`subtypesOf\` ys@ is true if @xs@ is the same size as @ys@, +-- and each element in @xs@ is a subtype of the corresponding element +-- in @ys@.. +subtypesOf :: (Ord u, ArrayShape shape) => + [TypeBase shape u] + -> [TypeBase shape u] + -> Bool +subtypesOf xs ys = length xs == length ys && + and (zipWith subtypeOf xs ys) + +-- | Add the given uniqueness information to the types. +toDecl :: TypeBase shape NoUniqueness + -> Uniqueness + -> TypeBase shape Uniqueness +toDecl (Prim bt) _ = Prim bt +toDecl (Array et shape _) u = Array et shape u +toDecl (Mem space) _ = Mem space + +-- | Remove uniqueness information from the type. +fromDecl :: TypeBase shape Uniqueness + -> TypeBase shape NoUniqueness +fromDecl (Prim bt) = Prim bt +fromDecl (Array et shape _) = Array et shape NoUniqueness +fromDecl (Mem space) = Mem space + +-- | If an existential, then return its existential index. +isExt :: Ext a -> Maybe Int +isExt (Ext i) = Just i +isExt _ = Nothing + +-- | Given the existential return type of a function, and the shapes +-- of the values returned by the function, return the existential +-- shape context. That is, those sizes that are existential in the +-- return type. +extractShapeContext :: [TypeBase ExtShape u] -> [[a]] -> [a] +extractShapeContext ts shapes = + evalState (concat <$> zipWithM extract ts shapes) S.empty + where extract t shape = + catMaybes <$> zipWithM extract' (shapeDims $ arrayShape t) shape + extract' (Ext x) v = do + seen <- gets $ S.member x + if seen then return Nothing + else do modify $ S.insert x + return $ Just v + extract' (Free _) _ = return Nothing + +-- | The set of identifiers used for the shape context in the given +-- 'ExtType's. +shapeContext :: [TypeBase ExtShape u] -> S.Set Int +shapeContext = S.fromList + . concatMap (mapMaybe ext . shapeDims . arrayShape) + where ext (Ext x) = Just x + ext (Free _) = Nothing + +-- | If all dimensions of the given 'ExtType' are statically known, +-- return the corresponding list of 'Type'. +hasStaticShape :: ExtType -> Maybe Type +hasStaticShape (Prim bt) = Just $ Prim bt +hasStaticShape (Mem space) = Just $ Mem space +hasStaticShape (Array bt (Shape shape) u) = + Array bt <$> (Shape <$> mapM isFree shape) <*> pure u + where isFree (Free s) = Just s + isFree (Ext _) = Nothing + +-- | Given two lists of 'ExtType's of the same length, return a list +-- of 'ExtType's that is a subtype of the two operands. +generaliseExtTypes :: [TypeBase ExtShape u] + -> [TypeBase ExtShape u] + -> [TypeBase ExtShape u] +generaliseExtTypes rt1 rt2 = + evalState (zipWithM unifyExtShapes rt1 rt2) (0, M.empty) + where unifyExtShapes t1 t2 = + setArrayShape t1 . Shape <$> + zipWithM unifyExtDims + (shapeDims $ arrayShape t1) + (shapeDims $ arrayShape t2) + unifyExtDims (Free se1) (Free se2) + | se1 == se2 = return $ Free se1 -- Arbitrary + | otherwise = do (n,m) <- get + put (n + 1, m) + return $ Ext n + unifyExtDims (Ext x) (Ext y) + | x == y = Ext <$> (maybe (new x) return =<< + gets (M.lookup x . snd)) + unifyExtDims (Ext x) _ = Ext <$> new x + unifyExtDims _ (Ext x) = Ext <$> new x + new x = do (n,m) <- get + put (n + 1, M.insert x n m) + return n + +-- | Given a list of 'ExtType's and a list of "forbidden" names, +-- modify the dimensions of the 'ExtType's such that they are 'Ext' +-- where they were previously 'Free' with a variable in the set of +-- forbidden names. +existentialiseExtTypes :: [VName] -> [ExtType] -> [ExtType] +existentialiseExtTypes inaccessible = map makeBoundShapesFree + where makeBoundShapesFree = + modifyArrayShape $ fmap checkDim + checkDim (Free (Var v)) + | Just i <- v `elemIndex` inaccessible = + Ext i + checkDim d = d + +-- | In the call @shapeMapping ts1 ts2@, the lists @ts1@ and @ts@ must +-- be of equal length and their corresponding elements have the same +-- types modulo exact dimensions (but matching array rank is +-- important). The result is a mapping from named dimensions of @ts1@ +-- to a set of the corresponding dimensions in @ts2@ (because they may +-- not fit exactly). +-- +-- This function is useful when @ts1@ are the value parameters of some +-- function and @ts2@ are the value arguments, and we need to figure +-- out which shape context to pass. +shapeMapping :: [TypeBase Shape u0] -> [TypeBase Shape u1] -> M.Map VName (S.Set SubExp) +shapeMapping ts = shapeMapping' ts . map arrayDims + +-- | Like @shapeMapping@, but works with explicit dimensions. +shapeMapping' :: Ord a => [TypeBase Shape u] -> [[a]] -> M.Map VName (S.Set a) +shapeMapping' = dimMapping arrayDims id match (M.unionWith (<>)) + where match Constant{} _ = M.empty + match (Var v) dim = M.singleton v $ S.singleton dim + +-- | Like 'shapeMapping', but produces a mapping for the dimensions context. +shapeExtMapping :: [TypeBase ExtShape u] -> [TypeBase Shape u1] -> M.Map Int SubExp +shapeExtMapping = dimMapping arrayExtDims arrayDims match mappend + where match Free{} _ = mempty + match (Ext i) dim = M.singleton i dim + +dimMapping :: Monoid res => + (t1 -> [dim1]) -> (t2 -> [dim2]) -> (dim1 -> dim2 -> res) + -> (res -> res -> res) + -> [t1] -> [t2] + -> res +dimMapping getDims1 getDims2 f comb ts1 ts2 = + foldl' comb mempty $ concat $ zipWith (zipWith f) (map getDims1 ts1) (map getDims2 ts2) + +-- | @IntType Int8@ +int8 :: PrimType +int8 = IntType Int8 + +-- | @IntType Int16@ +int16 :: PrimType +int16 = IntType Int16 + +-- | @IntType Int32@ +int32 :: PrimType +int32 = IntType Int32 + +-- | @IntType Int64@ +int64 :: PrimType +int64 = IntType Int64 + +-- | @FloatType Float32@ +float32 :: PrimType +float32 = FloatType Float32 + +-- | @FloatType Float64@ +float64 :: PrimType +float64 = FloatType Float64 + +-- | Typeclass for things that contain 'Type's. +class Typed t where + typeOf :: t -> Type + +instance Typed Type where + typeOf = id + +instance Typed DeclType where + typeOf = fromDecl + +instance Typed Ident where + typeOf = identType + +instance Typed dec => Typed (Param dec) where + typeOf = typeOf . paramDec + +instance Typed dec => Typed (PatElemT dec) where + typeOf = typeOf . patElemDec + +instance Typed b => Typed (a,b) where + typeOf = typeOf . snd + +-- | Typeclass for things that contain 'DeclType's. +class DeclTyped t where + declTypeOf :: t -> DeclType + +instance DeclTyped DeclType where + declTypeOf = id + +instance DeclTyped dec => DeclTyped (Param dec) where + declTypeOf = declTypeOf . paramDec + +-- | Typeclass for things that contain 'ExtType's. +class FixExt t => ExtTyped t where + extTypeOf :: t -> ExtType + +instance ExtTyped ExtType where + extTypeOf = id + +-- | Typeclass for things that contain 'DeclExtType's. +class FixExt t => DeclExtTyped t where + declExtTypeOf :: t -> DeclExtType + +instance DeclExtTyped DeclExtType where + declExtTypeOf = id + +-- | Typeclass for things whose type can be changed. +class Typed a => SetType a where + setType :: a -> Type -> a + +instance SetType Type where + setType _ t = t + +instance SetType b => SetType (a, b) where + setType (a, b) t = (a, setType b t) + +instance SetType dec => SetType (PatElemT dec) where + setType (PatElem name dec) t = + PatElem name $ setType dec t + +-- | Something with an existential context that can be (partially) +-- fixed. +class FixExt t where + -- | Fix the given existentional variable to the indicated free + -- value. + fixExt :: Int -> SubExp -> t -> t + +instance (FixExt shape, ArrayShape shape) => FixExt (TypeBase shape u) where + fixExt i se = modifyArrayShape $ fixExt i se + +instance FixExt d => FixExt (ShapeBase d) where + fixExt i se = fmap $ fixExt i se + +instance FixExt a => FixExt [a] where + fixExt i se = fmap $ fixExt i se + +instance FixExt ExtSize where + fixExt i se (Ext j) | j > i = Ext $ j - 1 + | j == i = Free se + | otherwise = Ext j + fixExt _ _ (Free x) = Free x + +instance FixExt () where + fixExt _ _ () = () diff --git a/src/Futhark/IR/Ranges.hs b/src/Futhark/IR/Ranges.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/IR/Ranges.hs @@ -0,0 +1,187 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | A representation where all bindings are annotated with range +-- information. +module Futhark.IR.Ranges + ( -- * The Lore definition + Ranges + , module Futhark.IR.Prop.Ranges + -- * Module re-exports + , module Futhark.IR.Prop + , module Futhark.IR.Traversals + , module Futhark.IR.Pretty + , module Futhark.IR.Syntax + -- * Adding ranges + , addRangesToPattern + , mkRangedBody + , mkPatternRanges + , mkBodyRanges + -- * Removing ranges + , removeProgRanges + , removeStmRanges + , removeLambdaRanges + ) +where + +import Control.Monad.Identity +import Control.Monad.Reader + +import Futhark.IR.Syntax +import Futhark.IR.Prop +import Futhark.IR.Prop.Aliases +import Futhark.IR.Prop.Ranges +import Futhark.IR.Traversals +import Futhark.IR.Pretty +import Futhark.Analysis.Rephrase +import qualified Futhark.Util.Pretty as PP + +-- | The lore for the basic representation. +data Ranges lore + +instance (Decorations lore, CanBeRanged (Op lore)) => + Decorations (Ranges lore) where + type LetDec (Ranges lore) = (Range, LetDec lore) + type ExpDec (Ranges lore) = ExpDec lore + type BodyDec (Ranges lore) = ([Range], BodyDec lore) + type FParamInfo (Ranges lore) = FParamInfo lore + type LParamInfo (Ranges lore) = LParamInfo lore + type RetType (Ranges lore) = RetType lore + type BranchType (Ranges lore) = BranchType lore + type Op (Ranges lore) = OpWithRanges (Op lore) + +withoutRanges :: (HasScope (Ranges lore) m, Monad m) => + ReaderT (Scope lore) m a -> + m a +withoutRanges m = do + scope <- asksScope $ fmap unRange + runReaderT m scope + where unRange :: NameInfo (Ranges lore) -> NameInfo lore + unRange (LetName (_, x)) = LetName x + unRange (FParamName x) = FParamName x + unRange (LParamName x) = LParamName x + unRange (IndexName x) = IndexName x + +instance (ASTLore lore, CanBeRanged (Op lore)) => + ASTLore (Ranges lore) where + expTypesFromPattern = + withoutRanges . expTypesFromPattern . removePatternRanges + +instance RangeOf (Range, dec) where + rangeOf = fst + +instance RangesOf ([Range], dec) where + rangesOf = fst + +instance PrettyAnnot (PatElemT dec) => + PrettyAnnot (PatElemT (Range, dec)) where + + ppAnnot patelem = + range_annot <> inner_annot + where range_annot = + case fst . patElemDec $ patelem of + (Nothing, Nothing) -> Nothing + range -> + Just $ PP.oneLine $ + PP.text "-- " <> PP.ppr (patElemName patelem) <> PP.text " range: " <> + PP.ppr range + inner_annot = ppAnnot $ fmap snd patelem + + +instance (PrettyLore lore, CanBeRanged (Op lore)) => PrettyLore (Ranges lore) where + ppExpLore dec = ppExpLore dec . removeExpRanges + +removeRanges :: CanBeRanged (Op lore) => Rephraser Identity (Ranges lore) lore +removeRanges = Rephraser { rephraseExpLore = return + , rephraseLetBoundLore = return . snd + , rephraseBodyLore = return . snd + , rephraseFParamLore = return + , rephraseLParamLore = return + , rephraseRetType = return + , rephraseBranchType = return + , rephraseOp = return . removeOpRanges + } + +-- | Remove range information from program. +removeProgRanges :: CanBeRanged (Op lore) => + Prog (Ranges lore) -> Prog lore +removeProgRanges = runIdentity . rephraseProg removeRanges + +removeExpRanges :: CanBeRanged (Op lore) => + Exp (Ranges lore) -> Exp lore +removeExpRanges = runIdentity . rephraseExp removeRanges + +removeBodyRanges :: CanBeRanged (Op lore) => + Body (Ranges lore) -> Body lore +removeBodyRanges = runIdentity . rephraseBody removeRanges + +-- | Remove range information from statement. +removeStmRanges :: CanBeRanged (Op lore) => + Stm (Ranges lore) -> Stm lore +removeStmRanges = runIdentity . rephraseStm removeRanges + +-- | Remove range information from lambda. +removeLambdaRanges :: CanBeRanged (Op lore) => + Lambda (Ranges lore) -> Lambda lore +removeLambdaRanges = runIdentity . rephraseLambda removeRanges + +removePatternRanges :: PatternT (Range, a) + -> PatternT a +removePatternRanges = runIdentity . rephrasePattern (return . snd) + +-- | Add ranges to the pattern corresponding to this expression. +addRangesToPattern :: (ASTLore lore, CanBeRanged (Op lore)) => + Pattern lore -> Exp (Ranges lore) + -> Pattern (Ranges lore) +addRangesToPattern pat e = + uncurry Pattern $ mkPatternRanges pat e + +-- | Construct a body with the 'Ranges' lore. +mkRangedBody :: BodyDec lore -> Stms (Ranges lore) -> Result + -> Body (Ranges lore) +mkRangedBody innerlore bnds res = + Body (mkBodyRanges bnds res, innerlore) bnds res + +-- | Find the ranges for the pattern elements. +mkPatternRanges :: (ASTLore lore, CanBeRanged (Op lore)) => + Pattern lore + -> Exp (Ranges lore) + -> ([PatElemT (Range, LetDec lore)], + [PatElemT (Range, LetDec lore)]) +mkPatternRanges pat e = + (map (`addRanges` unknownRange) $ patternContextElements pat, + zipWith addRanges (patternValueElements pat) ranges) + where addRanges patElem range = + let innerlore = patElemDec patElem + in patElem `setPatElemLore` (range, innerlore) + ranges = expRanges e + +-- | Find the ranges for the body result. +mkBodyRanges :: Stms lore -> Result -> [Range] +mkBodyRanges bnds = map $ removeUnknownBounds . rangeOf + where boundInBnds = + foldMap (namesFromList . patternNames . stmPattern) bnds + removeUnknownBounds (lower,upper) = + (removeUnknownBound lower, + removeUnknownBound upper) + removeUnknownBound (Just bound) + | freeIn bound `namesIntersect` boundInBnds = Nothing + | otherwise = Just bound + removeUnknownBound Nothing = + Nothing + +-- It is convenient for a wrapped aliased lore to also be aliased. + +instance AliasesOf dec => AliasesOf ([Range], dec) where + aliasesOf = aliasesOf . snd + +instance AliasesOf dec => AliasesOf (Range, dec) where + aliasesOf = aliasesOf . snd + +instance (Aliased lore, CanBeRanged (Op lore), + AliasedOp (OpWithRanges (Op lore))) => Aliased (Ranges lore) where + bodyAliases = bodyAliases . removeBodyRanges + consumedInBody = consumedInBody . removeBodyRanges diff --git a/src/Futhark/IR/RetType.hs b/src/Futhark/IR/RetType.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/IR/RetType.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE FlexibleInstances, TypeFamilies #-} +-- | This module exports a type class covering representations of +-- function return types. +module Futhark.IR.RetType + ( + IsBodyType (..) + , IsRetType (..) + , expectedTypes + ) + where + +import qualified Data.Map.Strict as M + +import Futhark.IR.Syntax.Core +import Futhark.IR.Prop.Types + +-- | A type representing the return type of a body. It should contain +-- at least the information contained in a list of 'ExtType's, but may +-- have more, notably an existential context. +class (Show rt, Eq rt, Ord rt, ExtTyped rt) => IsBodyType rt where + -- | Construct a body type from a primitive type. + primBodyType :: PrimType -> rt + +instance IsBodyType ExtType where + primBodyType = Prim + +-- | A type representing the return type of a function. In practice, +-- a list of these will be used. It should contain at least the +-- information contained in an 'ExtType', but may have more, notably +-- an existential context. +class (Show rt, Eq rt, Ord rt, DeclExtTyped rt) => IsRetType rt where + -- | Contruct a return type from a primitive type. + primRetType :: PrimType -> rt + + -- | Given a function return type, the parameters of the function, + -- and the arguments for a concrete call, return the instantiated + -- return type for the concrete call, if valid. + applyRetType :: Typed dec => + [rt] + -> [Param dec] + -> [(SubExp, Type)] + -> Maybe [rt] + +-- | Given shape parameter names and value parameter types, produce the +-- types of arguments accepted. +expectedTypes :: Typed t => [VName] -> [t] -> [SubExp] -> [Type] +expectedTypes shapes value_ts args = map (correctDims . typeOf) value_ts + where parammap :: M.Map VName SubExp + parammap = M.fromList $ zip shapes args + + correctDims t = + t `setArrayShape` + Shape (map correctDim $ shapeDims $ arrayShape t) + + correctDim (Constant v) = Constant v + correctDim (Var v) + | Just se <- M.lookup v parammap = se + | otherwise = Var v + +instance IsRetType DeclExtType where + primRetType = Prim + + applyRetType extret params args = + if length args == length params && + and (zipWith subtypeOf argtypes $ + expectedTypes (map paramName params) params $ map fst args) + then Just $ map correctExtDims extret + else Nothing + where argtypes = map snd args + + parammap :: M.Map VName SubExp + parammap = M.fromList $ zip (map paramName params) (map fst args) + + correctExtDims t = + t `setArrayShape` + Shape (map correctExtDim $ shapeDims $ arrayShape t) + + correctExtDim (Ext i) = Ext i + correctExtDim (Free d) = Free $ correctDim d + + correctDim (Constant v) = Constant v + correctDim (Var v) + | Just se <- M.lookup v parammap = se + | otherwise = Var v diff --git a/src/Futhark/IR/SOACS.hs b/src/Futhark/IR/SOACS.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/IR/SOACS.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE Safe #-} +-- | A simple representation with SOACs and nested parallelism. +module Futhark.IR.SOACS + ( -- * The Lore definition + SOACS + -- * Syntax types + , Body + , Stm + , Pattern + , Exp + , Lambda + , FParam + , LParam + , RetType + , PatElem + -- * Module re-exports + , module Futhark.IR.Prop + , module Futhark.IR.Traversals + , module Futhark.IR.Pretty + , module Futhark.IR.Syntax + , module Futhark.IR.SOACS.SOAC + , AST.LambdaT(Lambda) + , AST.BodyT(Body) + , AST.PatternT(Pattern) + , AST.PatElemT(PatElem) + ) +where + +import qualified Futhark.IR.Syntax as AST +import Futhark.IR.Syntax + hiding (Exp, Body, Stm, + Pattern, Lambda, FParam, LParam, RetType, PatElem) +import Futhark.IR.SOACS.SOAC +import Futhark.IR.Prop +import Futhark.IR.Traversals +import Futhark.IR.Pretty +import Futhark.Binder +import Futhark.Construct +import qualified Futhark.TypeCheck as TypeCheck + +-- This module could be written much nicer if Haskell had functors +-- like Standard ML. Instead, we have to abuse the namespace/module +-- system. + +-- | The lore for the basic representation. +data SOACS + +instance Decorations SOACS where + type Op SOACS = SOAC SOACS + +instance ASTLore SOACS where + expTypesFromPattern = return . expExtTypesFromPattern + +type Exp = AST.Exp SOACS +type Body = AST.Body SOACS +type Stm = AST.Stm SOACS +type Pattern = AST.Pattern SOACS +type Lambda = AST.Lambda SOACS +type FParam = AST.FParam SOACS +type LParam = AST.LParam SOACS +type RetType = AST.RetType SOACS +type PatElem = AST.PatElem SOACS + +instance TypeCheck.CheckableOp SOACS where + checkOp = typeCheckSOAC + +instance TypeCheck.Checkable SOACS where + +instance Bindable SOACS where + mkBody = AST.Body () + mkExpPat ctx val _ = basicPattern ctx val + mkExpDec _ _ = () + mkLetNames = simpleMkLetNames + +instance BinderOps SOACS where + +instance PrettyLore SOACS where diff --git a/src/Futhark/IR/SOACS/SOAC.hs b/src/Futhark/IR/SOACS/SOAC.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/IR/SOACS/SOAC.hs @@ -0,0 +1,791 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ConstraintKinds #-} +-- | Definition of /Second-Order Array Combinators/ (SOACs), which are +-- the main form of parallelism in the early stages of the compiler. +module Futhark.IR.SOACS.SOAC + ( SOAC(..) + , StreamOrd(..) + , StreamForm(..) + , ScremaForm(..) + , HistOp(..) + , Scan(..) + , scanResults + , singleScan + , Reduce(..) + , redResults + , singleReduce + + -- * Utility + , getStreamAccums + , scremaType + , soacType + + , typeCheckSOAC + + , mkIdentityLambda + , isIdentityLambda + , nilFn + , scanomapSOAC + , redomapSOAC + , scanSOAC + , reduceSOAC + , mapSOAC + , isScanomapSOAC + , isRedomapSOAC + , isScanSOAC + , isReduceSOAC + , isMapSOAC + + , ppScrema + , ppHist + + -- * Generic traversal + , SOACMapper(..) + , identitySOACMapper + , mapSOACM + ) + where + +import Control.Monad.State.Strict +import Control.Monad.Writer +import Control.Monad.Identity +import qualified Data.Map.Strict as M +import Data.Maybe +import Data.List (intersperse) + +import Futhark.IR +import qualified Futhark.Analysis.Alias as Alias +import qualified Futhark.Util.Pretty as PP +import Futhark.Util.Pretty (ppr, Doc, Pretty, parens, comma, (), (<+>), commasep, text) +import Futhark.IR.Prop.Aliases +import Futhark.Transform.Substitute +import Futhark.Transform.Rename +import Futhark.Optimise.Simplify.Lore +import Futhark.IR.Ranges (Ranges, removeLambdaRanges) +import Futhark.IR.Prop.Ranges +import Futhark.IR.Aliases (Aliases, removeLambdaAliases) +import qualified Futhark.Analysis.SymbolTable as ST +import Futhark.Analysis.PrimExp.Convert +import qualified Futhark.TypeCheck as TC +import Futhark.Analysis.Metrics +import qualified Futhark.Analysis.Range as Range +import Futhark.Construct +import Futhark.Util (maybeNth, chunks) + +-- | A second-order array combinator (SOAC). +data SOAC lore = + Stream SubExp (StreamForm lore) (Lambda lore) [VName] + | Scatter SubExp (Lambda lore) [VName] [(SubExp, Int, VName)] + -- ^ @Scatter @ + -- + -- + -- + -- is the length of each index array and value array, since they + -- all must be the same length for any fusion to make sense. If you have a + -- list of index-value array pairs of different sizes, you need to use + -- multiple writes instead. + -- + -- The lambda body returns the output in this manner: + -- + -- [index_0, index_1, ..., index_n, value_0, value_1, ..., value_n] + -- + -- This must be consistent along all Scatter-related optimisations. + | Hist SubExp [HistOp lore] (Lambda lore) [VName] + -- ^ @Hist @ + -- + -- The first SubExp is the length of the input arrays. The first + -- list describes the operations to perform. The t'Lambda' is the + -- bucket function. Finally comes the input images. + | Screma SubExp (ScremaForm lore) [VName] + -- ^ A combination of scan, reduction, and map. The first + -- t'SubExp' is the size of the input arrays. + deriving (Eq, Ord, Show) + +-- | Information about computing a single histogram. +data HistOp lore = HistOp { histWidth :: SubExp + , histRaceFactor :: SubExp + -- ^ Race factor @RF@ means that only @1/RF@ + -- bins are used. + , histDest :: [VName] + , histNeutral :: [SubExp] + , histOp :: Lambda lore + } + deriving (Eq, Ord, Show) + +-- | Is the stream chunk required to correspond to a contiguous +-- subsequence of the original input ('InOrder') or not? 'Disorder' +-- streams can be more efficient, but not all algorithms work with +-- this. +data StreamOrd = InOrder | Disorder + deriving (Eq, Ord, Show) + +-- | What kind of stream is this? +data StreamForm lore = + Parallel StreamOrd Commutativity (Lambda lore) [SubExp] + | Sequential [SubExp] + deriving (Eq, Ord, Show) + +-- | The essential parts of a 'Screma' factored out (everything +-- except the input arrays). +data ScremaForm lore = ScremaForm + [Scan lore] + [Reduce lore] + (Lambda lore) + deriving (Eq, Ord, Show) + +singleBinOp :: Bindable lore => [Lambda lore] -> Lambda lore +singleBinOp lams = + Lambda { lambdaParams = concatMap xParams lams ++ concatMap yParams lams + , lambdaReturnType = concatMap lambdaReturnType lams + , lambdaBody = mkBody (mconcat (map (bodyStms . lambdaBody) lams)) + (concatMap (bodyResult . lambdaBody) lams) + } + where xParams lam = take (length (lambdaReturnType lam)) (lambdaParams lam) + yParams lam = drop (length (lambdaReturnType lam)) (lambdaParams lam) + +-- | How to compute a single scan result. +data Scan lore = Scan { scanLambda :: Lambda lore + , scanNeutral :: [SubExp] + } + deriving (Eq, Ord, Show) + +-- | How many reduction results are produced by these 'Scan's? +scanResults :: [Scan lore] -> Int +scanResults = sum . map (length . scanNeutral) + +-- | Combine multiple scan operators to a single operator. +singleScan :: Bindable lore => [Scan lore] -> Scan lore +singleScan scans = + let scan_nes = concatMap scanNeutral scans + scan_lam = singleBinOp $ map scanLambda scans + in Scan scan_lam scan_nes + +-- | How to compute a single reduction result. +data Reduce lore = Reduce { redComm :: Commutativity + , redLambda :: Lambda lore + , redNeutral :: [SubExp] + } + deriving (Eq, Ord, Show) + +-- | How many reduction results are produced by these 'Reduce's? +redResults :: [Reduce lore] -> Int +redResults = sum . map (length . redNeutral) + +-- | Combine multiple reduction operators to a single operator. +singleReduce :: Bindable lore => [Reduce lore] -> Reduce lore +singleReduce reds = + let red_nes = concatMap redNeutral reds + red_lam = singleBinOp $ map redLambda reds + in Reduce (mconcat (map redComm reds)) red_lam red_nes + +-- | The types produced by a single 'Screma', given the size of the +-- input array. +scremaType :: SubExp -> ScremaForm lore -> [Type] +scremaType w (ScremaForm scans reds map_lam) = + scan_tps ++ red_tps ++ map (`arrayOfRow` w) map_tps + where scan_tps = map (`arrayOfRow` w) $ + concatMap (lambdaReturnType . scanLambda) scans + red_tps = concatMap (lambdaReturnType . redLambda) reds + map_tps = drop (length scan_tps + length red_tps) $ lambdaReturnType map_lam + +-- | Construct a lambda that takes parameters of the given types and +-- simply returns them unchanged. +mkIdentityLambda :: (Bindable lore, MonadFreshNames m) => + [Type] -> m (Lambda lore) +mkIdentityLambda ts = do + params <- mapM (newParam "x") ts + return Lambda { lambdaParams = params + , lambdaBody = mkBody mempty $ map (Var . paramName) params + , lambdaReturnType = ts } + +-- | Is the given lambda an identity lambda? +isIdentityLambda :: Lambda lore -> Bool +isIdentityLambda lam = bodyResult (lambdaBody lam) == + map (Var . paramName) (lambdaParams lam) + +-- | A lambda with no parameters that returns no values. +nilFn :: Bindable lore => Lambda lore +nilFn = Lambda mempty (mkBody mempty mempty) mempty + +-- | Construct a Screma with possibly multiple scans, and +-- the given map function. +scanomapSOAC :: [Scan lore] -> Lambda lore -> ScremaForm lore +scanomapSOAC scans = ScremaForm scans [] + +-- | Construct a Screma with possibly multiple reductions, and +-- the given map function. +redomapSOAC :: [Reduce lore] -> Lambda lore -> ScremaForm lore +redomapSOAC = ScremaForm [] + +-- | Construct a Screma with possibly multiple scans, and identity map +-- function. +scanSOAC :: (Bindable lore, MonadFreshNames m) => + [Scan lore] -> m (ScremaForm lore) +scanSOAC scans = scanomapSOAC scans <$> mkIdentityLambda ts + where ts = concatMap (lambdaReturnType . scanLambda) scans + +-- | Construct a Screma with possibly multiple reductions, and +-- identity map function. +reduceSOAC :: (Bindable lore, MonadFreshNames m) => + [Reduce lore] -> m (ScremaForm lore) +reduceSOAC reds = redomapSOAC reds <$> mkIdentityLambda ts + where ts = concatMap (lambdaReturnType . redLambda) reds + +-- | Construct a Screma corresponding to a map. +mapSOAC :: Lambda lore -> ScremaForm lore +mapSOAC = ScremaForm [] [] + +-- | Does this Screma correspond to a scan-map composition? +isScanomapSOAC :: ScremaForm lore -> Maybe ([Scan lore], Lambda lore) +isScanomapSOAC (ScremaForm scans reds map_lam) = do + guard $ null reds + guard $ not $ null scans + return (scans, map_lam) + +-- | Does this Screma correspond to pure scan? +isScanSOAC :: ScremaForm lore -> Maybe [Scan lore] +isScanSOAC form = do (scans, map_lam) <- isScanomapSOAC form + guard $ isIdentityLambda map_lam + return scans + +-- | Does this Screma correspond to a reduce-map composition? +isRedomapSOAC :: ScremaForm lore -> Maybe ([Reduce lore], Lambda lore) +isRedomapSOAC (ScremaForm scans reds map_lam) = do + guard $ null scans + guard $ not $ null reds + return (reds, map_lam) + +-- | Does this Screma correspond to a pure reduce? +isReduceSOAC :: ScremaForm lore -> Maybe [Reduce lore] +isReduceSOAC form = do (reds, map_lam) <- isRedomapSOAC form + guard $ isIdentityLambda map_lam + return reds + +-- | Does this Screma correspond to a simple map, without any +-- reduction or scan results? +isMapSOAC :: ScremaForm lore -> Maybe (Lambda lore) +isMapSOAC (ScremaForm scans reds map_lam) = do + guard $ null scans + guard $ null reds + return map_lam + +-- | Like 'Mapper', but just for 'SOAC's. +data SOACMapper flore tlore m = SOACMapper { + mapOnSOACSubExp :: SubExp -> m SubExp + , mapOnSOACLambda :: Lambda flore -> m (Lambda tlore) + , mapOnSOACVName :: VName -> m VName + } + +-- | A mapper that simply returns the SOAC verbatim. +identitySOACMapper :: Monad m => SOACMapper lore lore m +identitySOACMapper = SOACMapper { mapOnSOACSubExp = return + , mapOnSOACLambda = return + , mapOnSOACVName = return + } + +-- | Map a monadic action across the immediate children of a +-- SOAC. The mapping does not descend recursively into subexpressions +-- and is done left-to-right. +mapSOACM :: (Applicative m, Monad m) => + SOACMapper flore tlore m -> SOAC flore -> m (SOAC tlore) +mapSOACM tv (Stream size form lam arrs) = + Stream <$> mapOnSOACSubExp tv size <*> + mapOnStreamForm form <*> mapOnSOACLambda tv lam <*> + mapM (mapOnSOACVName tv) arrs + where mapOnStreamForm (Parallel o comm lam0 acc) = + Parallel o comm <$> + mapOnSOACLambda tv lam0 <*> + mapM (mapOnSOACSubExp tv) acc + mapOnStreamForm (Sequential acc) = + Sequential <$> mapM (mapOnSOACSubExp tv) acc +mapSOACM tv (Scatter len lam ivs as) = + Scatter + <$> mapOnSOACSubExp tv len + <*> mapOnSOACLambda tv lam + <*> mapM (mapOnSOACVName tv) ivs + <*> mapM (\(aw,an,a) -> (,,) <$> mapOnSOACSubExp tv aw <*> + pure an <*> mapOnSOACVName tv a) as +mapSOACM tv (Hist len ops bucket_fun imgs) = + Hist + <$> mapOnSOACSubExp tv len + <*> mapM (\(HistOp e rf arrs nes op) -> + HistOp <$> mapOnSOACSubExp tv e + <*> mapOnSOACSubExp tv rf + <*> mapM (mapOnSOACVName tv) arrs + <*> mapM (mapOnSOACSubExp tv) nes + <*> mapOnSOACLambda tv op) ops + <*> mapOnSOACLambda tv bucket_fun + <*> mapM (mapOnSOACVName tv) imgs +mapSOACM tv (Screma w (ScremaForm scans reds map_lam) arrs) = + Screma <$> mapOnSOACSubExp tv w <*> + (ScremaForm <$> + forM scans (\(Scan red_lam red_nes) -> + Scan <$> mapOnSOACLambda tv red_lam <*> + mapM (mapOnSOACSubExp tv) red_nes) <*> + forM reds (\(Reduce comm red_lam red_nes) -> + Reduce comm <$> mapOnSOACLambda tv red_lam <*> + mapM (mapOnSOACSubExp tv) red_nes) <*> + mapOnSOACLambda tv map_lam) + <*> mapM (mapOnSOACVName tv) arrs + +instance ASTLore lore => FreeIn (SOAC lore) where + freeIn' = flip execState mempty . mapSOACM free + where walk f x = modify (<>f x) >> return x + free = SOACMapper { mapOnSOACSubExp = walk freeIn' + , mapOnSOACLambda = walk freeIn' + , mapOnSOACVName = walk freeIn' + } + +instance ASTLore lore => Substitute (SOAC lore) where + substituteNames subst = + runIdentity . mapSOACM substitute + where substitute = + SOACMapper { mapOnSOACSubExp = return . substituteNames subst + , mapOnSOACLambda = return . substituteNames subst + , mapOnSOACVName = return . substituteNames subst + } + +instance ASTLore lore => Rename (SOAC lore) where + rename = mapSOACM renamer + where renamer = SOACMapper rename rename rename + +-- | The type of a SOAC. +soacType :: SOAC lore -> [Type] +soacType (Stream outersize form lam _) = + map (substNamesInType substs) rtp + where nms = map paramName $ take (1 + length accs) params + substs = M.fromList $ zip nms (outersize:accs) + Lambda params _ rtp = lam + accs = case form of + Parallel _ _ _ acc -> acc + Sequential acc -> acc +soacType (Scatter _w lam _ivs as) = + zipWith arrayOfRow val_ts ws + where val_ts = concatMap (take 1) $ chunks ns $ + drop (sum ns) $ lambdaReturnType lam + (ws, ns, _) = unzip3 as +soacType (Hist _len ops _bucket_fun _imgs) = do + op <- ops + map (`arrayOfRow` histWidth op) (lambdaReturnType $ histOp op) +soacType (Screma w form _arrs) = + scremaType w form + +instance TypedOp (SOAC lore) where + opType = pure . staticShapes . soacType + +instance (ASTLore lore, Aliased lore) => AliasedOp (SOAC lore) where + opAliases = map (const mempty) . soacType + + -- Only map functions can consume anything. The operands to scan + -- and reduce functions are always considered "fresh". + consumedInOp (Screma _ (ScremaForm _ _ map_lam) arrs) = + mapNames consumedArray $ consumedByLambda map_lam + where consumedArray v = fromMaybe v $ lookup v params_to_arrs + params_to_arrs = zip (map paramName $ lambdaParams map_lam) arrs + consumedInOp (Stream _ form lam arrs) = + namesFromList $ subExpVars $ + case form of Sequential accs -> + map (consumedArray accs) $ namesToList $ consumedByLambda lam + Parallel _ _ _ accs -> + map (consumedArray accs) $ namesToList $ consumedByLambda lam + where consumedArray accs v = fromMaybe (Var v) $ lookup v $ paramsToInput accs + -- Drop the chunk parameter, which cannot alias anything. + paramsToInput accs = zip + (map paramName $ drop 1 $ lambdaParams lam) + (accs++map Var arrs) + consumedInOp (Scatter _ _ _ as) = + namesFromList $ map (\(_, _, a) -> a) as + consumedInOp (Hist _ ops _ _) = + namesFromList $ concatMap histDest ops + +mapHistOp :: (Lambda flore -> Lambda tlore) + -> HistOp flore -> HistOp tlore +mapHistOp f (HistOp w rf dests nes lam) = + HistOp w rf dests nes $ f lam + +instance (ASTLore lore, + ASTLore (Aliases lore), + CanBeAliased (Op lore)) => CanBeAliased (SOAC lore) where + type OpWithAliases (SOAC lore) = SOAC (Aliases lore) + + addOpAliases (Stream size form lam arr) = + Stream size (analyseStreamForm form) + (Alias.analyseLambda lam) arr + where analyseStreamForm (Parallel o comm lam0 acc) = + Parallel o comm (Alias.analyseLambda lam0) acc + analyseStreamForm (Sequential acc) = Sequential acc + addOpAliases (Scatter len lam ivs as) = + Scatter len (Alias.analyseLambda lam) ivs as + addOpAliases (Hist len ops bucket_fun imgs) = + Hist len (map (mapHistOp Alias.analyseLambda) ops) + (Alias.analyseLambda bucket_fun) imgs + addOpAliases (Screma w (ScremaForm scans reds map_lam) arrs) = + Screma w (ScremaForm + (map onScan scans) + (map onRed reds) + (Alias.analyseLambda map_lam)) + arrs + where onRed red = red { redLambda = Alias.analyseLambda $ redLambda red } + onScan scan = scan { scanLambda = Alias.analyseLambda $ scanLambda scan } + + removeOpAliases = runIdentity . mapSOACM remove + where remove = SOACMapper return (return . removeLambdaAliases) return + +instance ASTLore lore => IsOp (SOAC lore) where + safeOp _ = False + cheapOp _ = True + +substNamesInType :: M.Map VName SubExp -> Type -> Type +substNamesInType _ tp@(Prim _) = tp +substNamesInType _ (Mem space) = Mem space +substNamesInType subs (Array btp shp u) = + let shp' = Shape $ map (substNamesInSubExp subs) (shapeDims shp) + in Array btp shp' u + +substNamesInSubExp :: M.Map VName SubExp -> SubExp -> SubExp +substNamesInSubExp _ e@(Constant _) = e +substNamesInSubExp subs (Var idd) = + M.findWithDefault (Var idd) idd subs + +instance (Ranged inner) => RangedOp (SOAC inner) where + opRanges op = replicate (length $ soacType op) unknownRange + +instance (ASTLore lore, CanBeRanged (Op lore)) => CanBeRanged (SOAC lore) where + type OpWithRanges (SOAC lore) = SOAC (Ranges lore) + + removeOpRanges = runIdentity . mapSOACM remove + where remove = SOACMapper return (return . removeLambdaRanges) return + addOpRanges (Stream w form lam arr) = + Stream w + (Range.runRangeM $ analyseStreamForm form) + (Range.runRangeM $ Range.analyseLambda lam) + arr + where analyseStreamForm (Sequential acc) = + return $ Sequential acc + analyseStreamForm (Parallel o comm lam0 acc) = do + lam0' <- Range.analyseLambda lam0 + return $ Parallel o comm lam0' acc + addOpRanges (Scatter len lam ivs as) = + Scatter len (Range.runRangeM $ Range.analyseLambda lam) ivs as + addOpRanges (Hist len ops bucket_fun imgs) = + Hist len (map (mapHistOp $ Range.runRangeM . Range.analyseLambda) ops) + (Range.runRangeM $ Range.analyseLambda bucket_fun) imgs + addOpRanges (Screma w (ScremaForm scans reds map_lam) arrs) = + Screma w (ScremaForm + (map onScan scans) + (map onRed reds) + (Range.runRangeM $ Range.analyseLambda map_lam)) + arrs + where onRed red = + red { redLambda = Range.runRangeM $ Range.analyseLambda $ redLambda red } + onScan red = + red { scanLambda = Range.runRangeM $ Range.analyseLambda $ scanLambda red } + +instance (ASTLore lore, CanBeWise (Op lore)) => CanBeWise (SOAC lore) where + type OpWithWisdom (SOAC lore) = SOAC (Wise lore) + + removeOpWisdom = runIdentity . mapSOACM remove + where remove = SOACMapper return (return . removeLambdaWisdom) return + +instance Decorations lore => ST.IndexOp (SOAC lore) where + indexOp vtable k soac [i] = do + (lam,se,arr_params,arrs) <- lambdaAndSubExp soac + let arr_indexes = M.fromList $ catMaybes $ zipWith arrIndex arr_params arrs + arr_indexes' = foldl expandPrimExpTable arr_indexes $ bodyStms $ lambdaBody lam + case se of + Var v -> uncurry (flip ST.Indexed) <$> M.lookup v arr_indexes' + _ -> Nothing + where lambdaAndSubExp (Screma _ (ScremaForm scans reds map_lam) arrs) = + nthMapOut (scanResults scans + redResults reds) map_lam arrs + lambdaAndSubExp _ = + Nothing + + nthMapOut num_accs lam arrs = do + se <- maybeNth (num_accs+k) $ bodyResult $ lambdaBody lam + return (lam, se, drop num_accs $ lambdaParams lam, arrs) + + arrIndex p arr = do + ST.Indexed cs pe <- ST.index' arr [i] vtable + return (paramName p, (pe,cs)) + + expandPrimExpTable table stm + | [v] <- patternNames $ stmPattern stm, + Just (pe,cs) <- + runWriterT $ primExpFromExp (asPrimExp table) $ stmExp stm, + all (`ST.elem` vtable) (unCertificates $ stmCerts stm) = + M.insert v (pe, stmCerts stm <> cs) table + | otherwise = + table + + asPrimExp table v + | Just (e,cs) <- M.lookup v table = tell cs >> return e + | Just (Prim pt) <- ST.lookupType v vtable = + return $ LeafExp v pt + | otherwise = lift Nothing + indexOp _ _ _ _ = Nothing + +-- | Type-check a SOAC. +typeCheckSOAC :: TC.Checkable lore => SOAC (Aliases lore) -> TC.TypeM lore () +typeCheckSOAC (Stream size form lam arrexps) = do + let accexps = getStreamAccums form + TC.require [Prim int32] size + accargs <- mapM TC.checkArg accexps + arrargs <- mapM lookupType arrexps + _ <- TC.checkSOACArrayArgs size arrexps + let chunk = head $ lambdaParams lam + let asArg t = (t, mempty) + inttp = Prim int32 + lamarrs'= map (`setOuterSize` Var (paramName chunk)) arrargs + let acc_len= length accexps + let lamrtp = take acc_len $ lambdaReturnType lam + unless (map TC.argType accargs == lamrtp) $ + TC.bad $ TC.TypeError "Stream with inconsistent accumulator type in lambda." + -- check reduce's lambda, if any + _ <- case form of + Parallel _ _ lam0 _ -> do + let acct = map TC.argType accargs + outerRetType = lambdaReturnType lam0 + TC.checkLambda lam0 $ map TC.noArgAliases $ accargs ++ accargs + unless (acct == outerRetType) $ + TC.bad $ TC.TypeError $ + "Initial value is of type " ++ prettyTuple acct ++ + ", but stream's reduce lambda returns type " ++ prettyTuple outerRetType ++ "." + _ -> return () + -- just get the dflow of lambda on the fakearg, which does not alias + -- arr, so we can later check that aliases of arr are not used inside lam. + let fake_lamarrs' = map asArg lamarrs' + TC.checkLambda lam $ asArg inttp : accargs ++ fake_lamarrs' + +typeCheckSOAC (Scatter w lam ivs as) = do + -- Requirements: + -- + -- 0. @lambdaReturnType@ of @lam@ must be a list + -- [index types..., value types]. + -- + -- 1. The number of index types must be equal to the number of value types + -- and the number of writes to arrays in @as@. + -- + -- 2. Each index type must have the type i32. + -- + -- 3. Each array in @as@ and the value types must have the same type + -- + -- 4. Each array in @as@ is consumed. This is not really a check, but more + -- of a requirement, so that e.g. the source is not hoisted out of a + -- loop, which will mean it cannot be consumed. + -- + -- 5. Each of ivs must be an array matching a corresponding lambda + -- parameters. + -- + -- Code: + + -- First check the input size. + TC.require [Prim int32] w + + -- 0. + let (_as_ws, as_ns, _as_vs) = unzip3 as + rts = lambdaReturnType lam + rtsLen = length rts `div` 2 + rtsI = take rtsLen rts + rtsV = drop rtsLen rts + + -- 1. + unless (rtsLen == sum as_ns) + $ TC.bad $ TC.TypeError "Scatter: Uneven number of index types, value types, and arrays outputs." + + -- 2. + forM_ rtsI $ \rtI -> unless (Prim int32 == rtI) $ + TC.bad $ TC.TypeError "Scatter: Index return type must be i32." + + forM_ (zip (chunks as_ns rtsV) as) $ \(rtVs, (aw, _, a)) -> do + -- All lengths must have type i32. + TC.require [Prim int32] aw + + -- 3. + forM_ rtVs $ \rtV -> TC.requireI [rtV `arrayOfRow` aw] a + + -- 4. + TC.consume =<< TC.lookupAliases a + + -- 5. + arrargs <- TC.checkSOACArrayArgs w ivs + TC.checkLambda lam arrargs + +typeCheckSOAC (Hist len ops bucket_fun imgs) = do + TC.require [Prim int32] len + + -- Check the operators. + forM_ ops $ \(HistOp dest_w rf dests nes op) -> do + nes' <- mapM TC.checkArg nes + TC.require [Prim int32] dest_w + TC.require [Prim int32] rf + + -- Operator type must match the type of neutral elements. + TC.checkLambda op $ map TC.noArgAliases $ nes' ++ nes' + let nes_t = map TC.argType nes' + unless (nes_t == lambdaReturnType op) $ + TC.bad $ TC.TypeError $ "Operator has return type " ++ + prettyTuple (lambdaReturnType op) ++ " but neutral element has type " ++ + prettyTuple nes_t + + -- Arrays must have proper type. + forM_ (zip nes_t dests) $ \(t, dest) -> do + TC.requireI [t `arrayOfRow` dest_w] dest + TC.consume =<< TC.lookupAliases dest + + -- Types of input arrays must equal parameter types for bucket function. + img' <- TC.checkSOACArrayArgs len imgs + TC.checkLambda bucket_fun img' + + -- Return type of bucket function must be an index for each + -- operation followed by the values to write. + nes_ts <- concat <$> mapM (mapM subExpType . histNeutral) ops + let bucket_ret_t = replicate (length ops) (Prim int32) ++ nes_ts + unless (bucket_ret_t == lambdaReturnType bucket_fun) $ + TC.bad $ TC.TypeError $ "Bucket function has return type " ++ + prettyTuple (lambdaReturnType bucket_fun) ++ " but should have type " ++ + prettyTuple bucket_ret_t + +typeCheckSOAC (Screma w (ScremaForm scans reds map_lam) arrs) = do + TC.require [Prim int32] w + arrs' <- TC.checkSOACArrayArgs w arrs + TC.checkLambda map_lam $ map TC.noArgAliases arrs' + + scan_nes' <- fmap concat $ forM scans $ \(Scan scan_lam scan_nes) -> do + scan_nes' <- mapM TC.checkArg scan_nes + let scan_t = map TC.argType scan_nes' + TC.checkLambda scan_lam $ map TC.noArgAliases $ scan_nes' ++ scan_nes' + unless (scan_t == lambdaReturnType scan_lam) $ + TC.bad $ TC.TypeError $ "Scan function returns type " ++ + prettyTuple (lambdaReturnType scan_lam) ++ " but neutral element has type " ++ + prettyTuple scan_t + return scan_nes' + + red_nes' <- fmap concat $ forM reds $ \(Reduce _ red_lam red_nes) -> do + red_nes' <- mapM TC.checkArg red_nes + let red_t = map TC.argType red_nes' + TC.checkLambda red_lam $ map TC.noArgAliases $ red_nes' ++ red_nes' + unless (red_t == lambdaReturnType red_lam) $ + TC.bad $ TC.TypeError $ "Reduce function returns type " ++ + prettyTuple (lambdaReturnType red_lam) ++ " but neutral element has type " ++ + prettyTuple red_t + return red_nes' + + let map_lam_ts = lambdaReturnType map_lam + + unless (take (length scan_nes' + length red_nes') map_lam_ts == + map TC.argType (scan_nes'++ red_nes')) $ + TC.bad $ TC.TypeError $ "Map function return type " ++ prettyTuple map_lam_ts ++ + " wrong for given scan and reduction functions." + +-- | Get Stream's accumulators as a sub-expression list +getStreamAccums :: StreamForm lore -> [SubExp] +getStreamAccums (Parallel _ _ _ accs) = accs +getStreamAccums (Sequential accs) = accs + +instance OpMetrics (Op lore) => OpMetrics (SOAC lore) where + opMetrics (Stream _ _ lam _) = + inside "Stream" $ lambdaMetrics lam + opMetrics (Scatter _len lam _ivs _as) = + inside "Scatter" $ lambdaMetrics lam + opMetrics (Hist _len ops bucket_fun _imgs) = + inside "Hist" $ mapM_ (lambdaMetrics . histOp) ops >> lambdaMetrics bucket_fun + opMetrics (Screma _ (ScremaForm scans reds map_lam) _) = + inside "Screma" $ do mapM_ (lambdaMetrics . scanLambda) scans + mapM_ (lambdaMetrics . redLambda) reds + lambdaMetrics map_lam + +instance PrettyLore lore => PP.Pretty (SOAC lore) where + ppr (Stream size form lam arrs) = + case form of + Parallel o comm lam0 acc -> + let ord_str = if o == Disorder then "Per" else "" + comm_str = case comm of Commutative -> "Comm" + Noncommutative -> "" + in text ("streamPar"++ord_str++comm_str) <> + parens (ppr size <> comma ppr lam0 comma ppr lam + commasep ( PP.braces (commasep $ map ppr acc) : map ppr arrs )) + Sequential acc -> + text "streamSeq" <> + parens (ppr size <> comma ppr lam <> comma + commasep ( PP.braces (commasep $ map ppr acc) : map ppr arrs )) + ppr (Scatter len lam ivs as) = + ppSOAC "scatter" len [lam] (Just (map Var ivs)) (map (\(_,n,a) -> (n,a)) as) + ppr (Hist len ops bucket_fun imgs) = + ppHist len ops bucket_fun imgs + ppr (Screma w (ScremaForm scans reds map_lam) arrs) + | null scans, null reds = + text "map" <> + parens (ppr w <> comma + ppr map_lam <> comma + commasep (map ppr arrs)) + + | null scans = + text "redomap" <> + parens (ppr w <> comma + PP.braces (mconcat $ intersperse (comma <> PP.line) $ map ppr reds) <> comma + ppr map_lam <> comma + commasep (map ppr arrs)) + + | null reds = + text "scanomap" <> + parens (ppr w <> comma + PP.braces (mconcat $ intersperse (comma <> PP.line) $ map ppr scans) <> comma + ppr map_lam <> comma + commasep (map ppr arrs)) + + ppr (Screma w form arrs) = ppScrema w form arrs + +-- | Prettyprint the given Screma. +ppScrema :: (PrettyLore lore, Pretty inp) => + SubExp -> ScremaForm lore -> [inp] -> Doc +ppScrema w (ScremaForm scans reds map_lam) arrs = + text "screma" <> + parens (ppr w <> comma + PP.braces (mconcat $ intersperse (comma <> PP.line) $ map ppr scans) <> comma + PP.braces (mconcat $ intersperse (comma <> PP.line) $ map ppr reds) <> comma + ppr map_lam <> comma + commasep (map ppr arrs)) + +instance PrettyLore lore => Pretty (Scan lore) where + ppr (Scan scan_lam scan_nes) = + ppr scan_lam <> comma PP.braces (commasep $ map ppr scan_nes) + +ppComm :: Commutativity -> Doc +ppComm Noncommutative = mempty +ppComm Commutative = text "commutative " + +instance PrettyLore lore => Pretty (Reduce lore) where + ppr (Reduce comm red_lam red_nes) = + ppComm comm <> ppr red_lam <> comma + PP.braces (commasep $ map ppr red_nes) + +-- | Prettyprint the given histogram operation. +ppHist :: (PrettyLore lore, Pretty inp) => + SubExp -> [HistOp lore] -> Lambda lore -> [inp] -> Doc +ppHist len ops bucket_fun imgs = + text "hist" <> + parens (ppr len <> comma + PP.braces (mconcat $ intersperse (comma <> PP.line) $ map ppOp ops) <> comma + ppr bucket_fun <> comma + commasep (map ppr imgs)) + where ppOp (HistOp w rf dests nes op) = + ppr w <> comma <+> ppr rf <> comma <+> PP.braces (commasep $ map ppr dests) <> comma + PP.braces (commasep $ map ppr nes) <> comma ppr op + +ppSOAC :: (Pretty fn, Pretty v) => + String -> SubExp -> [fn] -> Maybe [SubExp] -> [v] -> Doc +ppSOAC name size funs es as = + text name <> parens (ppr size <> comma + ppList funs + commasep (es' ++ map ppr as)) + where es' = maybe [] ((:[]) . ppTuple') es + +ppList :: Pretty a => [a] -> Doc +ppList as = case map ppr as of + [] -> mempty + a':as' -> foldl () (a' <> comma) $ map (<> comma) as' diff --git a/src/Futhark/IR/SOACS/Simplify.hs b/src/Futhark/IR/SOACS/Simplify.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/IR/SOACS/Simplify.hs @@ -0,0 +1,790 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module Futhark.IR.SOACS.Simplify + ( simplifySOACS + , simplifyLambda + , simplifyFun + , simplifyStms + , simplifyConsts + + , simpleSOACS + , simplifySOAC + + , soacRules + + , SOACS + ) +where + +import Control.Monad +import Control.Monad.Identity +import Control.Monad.State +import Control.Monad.Writer +import Data.Foldable +import Data.Either +import Data.List (partition, transpose, unzip6, zip6) +import Data.Maybe +import qualified Data.Map.Strict as M +import qualified Data.Set as S + +import Futhark.IR.SOACS +import qualified Futhark.IR as AST +import Futhark.IR.Prop.Aliases +import qualified Futhark.Optimise.Simplify.Engine as Engine +import qualified Futhark.Optimise.Simplify as Simplify +import Futhark.Optimise.Simplify.Rules +import Futhark.MonadFreshNames +import Futhark.Optimise.Simplify.Rule +import Futhark.Optimise.Simplify.ClosedForm +import Futhark.Optimise.Simplify.Lore +import Futhark.Tools +import Futhark.Pass +import qualified Futhark.Analysis.SymbolTable as ST +import qualified Futhark.Analysis.UsageTable as UT +import Futhark.Analysis.DataDependencies +import Futhark.Transform.Rename +import Futhark.Util + +simpleSOACS :: Simplify.SimpleOps SOACS +simpleSOACS = Simplify.bindableSimpleOps simplifySOAC + +simplifySOACS :: Prog SOACS -> PassM (Prog SOACS) +simplifySOACS = Simplify.simplifyProg simpleSOACS soacRules blockers + where blockers = Engine.noExtraHoistBlockers { Engine.getArraySizes = getShapeNames } + +-- | Getting the roots of what to hoist, for now only variable +-- names that represent shapes/sizes. +getShapeNames :: (LetDec lore ~ (VarWisdom, Type)) => + AST.Stm lore -> Names +getShapeNames bnd = + let tps1 = map patElemType $ patternElements $ stmPattern bnd + tps2 = map (snd . patElemDec) $ patternElements $ stmPattern bnd + in namesFromList $ subExpVars $ concatMap arrayDims (tps1 ++ tps2) + +simplifyFun :: MonadFreshNames m => + ST.SymbolTable (Wise SOACS) -> FunDef SOACS -> m (FunDef SOACS) +simplifyFun = + Simplify.simplifyFun simpleSOACS soacRules Engine.noExtraHoistBlockers + +simplifyLambda :: (HasScope SOACS m, MonadFreshNames m) => + Lambda -> [Maybe VName] -> m Lambda +simplifyLambda = + Simplify.simplifyLambda simpleSOACS soacRules Engine.noExtraHoistBlockers + +simplifyStms :: (HasScope SOACS m, MonadFreshNames m) => + Stms SOACS -> m (ST.SymbolTable (Wise SOACS), Stms SOACS) +simplifyStms stms = do + scope <- askScope + Simplify.simplifyStms simpleSOACS soacRules Engine.noExtraHoistBlockers + scope stms + +simplifyConsts :: MonadFreshNames m => + Stms SOACS -> m (ST.SymbolTable (Wise SOACS), Stms SOACS) +simplifyConsts = + Simplify.simplifyStms simpleSOACS soacRules Engine.noExtraHoistBlockers mempty + +simplifySOAC :: Simplify.SimplifiableLore lore => + Simplify.SimplifyOp lore (SOAC lore) +simplifySOAC (Stream outerdim form lam arr) = do + outerdim' <- Engine.simplify outerdim + (form', form_hoisted) <- simplifyStreamForm form + arr' <- mapM Engine.simplify arr + (lam', lam_hoisted) <- Engine.simplifyLambda lam (map Just arr) + return (Stream outerdim' form' lam' arr', form_hoisted <> lam_hoisted) + where simplifyStreamForm (Parallel o comm lam0 acc) = do + acc' <- mapM Engine.simplify acc + (lam0', hoisted) <- Engine.simplifyLambda lam0 $ + replicate (length $ lambdaParams lam0) Nothing + return (Parallel o comm lam0' acc', hoisted) + simplifyStreamForm (Sequential acc) = do + acc' <- mapM Engine.simplify acc + return (Sequential acc', mempty) + +simplifySOAC (Scatter len lam ivs as) = do + len' <- Engine.simplify len + (lam', hoisted) <- Engine.simplifyLambda lam $ map Just ivs + ivs' <- mapM Engine.simplify ivs + as' <- mapM Engine.simplify as + return (Scatter len' lam' ivs' as', hoisted) + +simplifySOAC (Hist w ops bfun imgs) = do + w' <- Engine.simplify w + (ops', hoisted) <- fmap unzip $ forM ops $ \(HistOp dests_w rf dests nes op) -> do + dests_w' <- Engine.simplify dests_w + rf' <- Engine.simplify rf + dests' <- Engine.simplify dests + nes' <- mapM Engine.simplify nes + (op', hoisted) <- Engine.simplifyLambda op $ replicate (length $ lambdaParams op) Nothing + return (HistOp dests_w' rf' dests' nes' op', hoisted) + imgs' <- mapM Engine.simplify imgs + (bfun', bfun_hoisted) <- Engine.simplifyLambda bfun $ map Just imgs + return (Hist w' ops' bfun' imgs', mconcat hoisted <> bfun_hoisted) + +simplifySOAC (Screma w (ScremaForm scans reds map_lam) arrs) = do + (scans', scans_hoisted) <- fmap unzip $ forM scans $ \(Scan lam nes) -> do + (lam', hoisted) <- Engine.simplifyLambda lam $ replicate (length nes) Nothing + nes' <- Engine.simplify nes + return (Scan lam' nes', hoisted) + + (reds', reds_hoisted) <- fmap unzip $ forM reds $ \(Reduce comm lam nes) -> do + (lam', hoisted) <- Engine.simplifyLambda lam $ replicate (length nes) Nothing + nes' <- Engine.simplify nes + return (Reduce comm lam' nes', hoisted) + + (map_lam', map_lam_hoisted) <- Engine.simplifyLambda map_lam $ map Just arrs + + (,) <$> (Screma <$> Engine.simplify w <*> + pure (ScremaForm scans' reds' map_lam') <*> + Engine.simplify arrs) <*> + pure (mconcat scans_hoisted <> mconcat reds_hoisted <> map_lam_hoisted) + +instance BinderOps (Wise SOACS) where + +fixLambdaParams :: (MonadBinder m, Bindable (Lore m), BinderOps (Lore m)) => + AST.Lambda (Lore m) -> [Maybe SubExp] -> m (AST.Lambda (Lore m)) +fixLambdaParams lam fixes = do + body <- runBodyBinder $ localScope (scopeOfLParams $ lambdaParams lam) $ do + zipWithM_ maybeFix (lambdaParams lam) fixes' + return $ lambdaBody lam + return lam { lambdaBody = body + , lambdaParams = map fst $ filter (isNothing . snd) $ + zip (lambdaParams lam) fixes' } + where fixes' = fixes ++ repeat Nothing + maybeFix p (Just x) = letBindNames [paramName p] $ BasicOp $ SubExp x + maybeFix _ Nothing = return () + +removeLambdaResults :: [Bool] -> AST.Lambda lore -> AST.Lambda lore +removeLambdaResults keep lam = lam { lambdaBody = lam_body' + , lambdaReturnType = ret } + where keep' :: [a] -> [a] + keep' = map snd . filter fst . zip (keep ++ repeat True) + lam_body = lambdaBody lam + lam_body' = lam_body { bodyResult = keep' $ bodyResult lam_body } + ret = keep' $ lambdaReturnType lam + +soacRules :: RuleBook (Wise SOACS) +soacRules = standardRules <> ruleBook topDownRules bottomUpRules + +topDownRules :: [TopDownRule (Wise SOACS)] +topDownRules = [RuleOp hoistCertificates, + RuleOp removeReplicateMapping, + RuleOp removeReplicateWrite, + RuleOp removeUnusedSOACInput, + RuleOp simplifyClosedFormReduce, + RuleOp simplifyKnownIterationSOAC, + RuleOp fuseConcatScatter, + RuleOp simplifyMapIota, + RuleOp moveTransformToInput + ] + +bottomUpRules :: [BottomUpRule (Wise SOACS)] +bottomUpRules = [RuleOp removeDeadMapping, + RuleOp removeDeadReduction, + RuleOp removeDeadWrite, + RuleBasicOp removeUnnecessaryCopy, + RuleOp liftIdentityMapping, + RuleOp liftIdentityStreaming, + RuleOp removeDuplicateMapOutput, + RuleOp mapOpToOp + ] + +-- Any certificates attached to a trivial Stm in the body might as +-- well be applied to the SOAC itself. +hoistCertificates :: TopDownRuleOp (Wise SOACS) +hoistCertificates vtable pat aux soac + | (soac', hoisted) <- runState (mapSOACM mapper soac) mempty, + hoisted /= mempty = + Simplify $ certifying (hoisted <> stmAuxCerts aux) $ letBind pat $ Op soac' + where mapper = identitySOACMapper { mapOnSOACLambda = onLambda } + onLambda lam = do + stms' <- mapM onStm $ bodyStms $ lambdaBody lam + return lam { lambdaBody = + mkBody stms' $ bodyResult $ lambdaBody lam } + onStm (Let se_pat se_aux (BasicOp (SubExp se))) = do + let (invariant, variant) = + partition (`ST.elem` vtable) $ + unCertificates $ stmAuxCerts se_aux + se_aux' = se_aux { stmAuxCerts = Certificates variant } + modify (Certificates invariant<>) + return $ Let se_pat se_aux' $ BasicOp $ SubExp se + onStm stm = return stm +hoistCertificates _ _ _ _ = + Skip + +liftIdentityMapping :: BottomUpRuleOp (Wise SOACS) +liftIdentityMapping (_, usages) pat _ (Screma w form arrs) + | Just fun <- isMapSOAC form = do + let inputMap = M.fromList $ zip (map paramName $ lambdaParams fun) arrs + free = freeIn $ lambdaBody fun + rettype = lambdaReturnType fun + ses = bodyResult $ lambdaBody fun + + freeOrConst (Var v) = v `nameIn` free + freeOrConst Constant{} = True + + checkInvariance (outId, Var v, _) (invariant, mapresult, rettype') + | Just inp <- M.lookup v inputMap = + let e | patElemName outId `UT.isConsumed` usages + || inp `UT.isConsumed` usages = + Copy inp + | otherwise = + SubExp $ Var inp + in ((Pattern [] [outId], BasicOp e) : invariant, + mapresult, + rettype') + checkInvariance (outId, e, t) (invariant, mapresult, rettype') + | freeOrConst e = ((Pattern [] [outId], BasicOp $ Replicate (Shape [w]) e) : invariant, + mapresult, + rettype') + | otherwise = (invariant, + (outId, e) : mapresult, + t : rettype') + + case foldr checkInvariance ([], [], []) $ + zip3 (patternElements pat) ses rettype of + ([], _, _) -> Skip + (invariant, mapresult, rettype') -> Simplify $ do + let (pat', ses') = unzip mapresult + fun' = fun { lambdaBody = (lambdaBody fun) { bodyResult = ses' } + , lambdaReturnType = rettype' + } + mapM_ (uncurry letBind) invariant + letBindNames (map patElemName pat') $ Op $ Screma w (mapSOAC fun') arrs +liftIdentityMapping _ _ _ _ = Skip + +liftIdentityStreaming :: BottomUpRuleOp (Wise SOACS) +liftIdentityStreaming _ (Pattern [] pes) _ (Stream w form lam arrs) + | (variant_map, invariant_map) <- + partitionEithers $ map isInvariantRes $ zip3 map_ts map_pes map_res, + not $ null invariant_map = Simplify $ do + + forM_ invariant_map $ \(pe, arr) -> + letBind (Pattern [] [pe]) $ BasicOp $ Copy arr + + let (variant_map_ts, variant_map_pes, variant_map_res) = unzip3 variant_map + lam' = lam { lambdaBody = (lambdaBody lam) { bodyResult = fold_res ++ variant_map_res } + , lambdaReturnType = fold_ts ++ variant_map_ts } + + letBind (Pattern [] $ fold_pes ++ variant_map_pes) $ + Op $ Stream w form lam' arrs + where num_folds = length $ getStreamAccums form + (fold_pes, map_pes) = splitAt num_folds pes + (fold_ts, map_ts) = splitAt num_folds $ lambdaReturnType lam + lam_res = bodyResult $ lambdaBody lam + (fold_res, map_res) = splitAt num_folds lam_res + params_to_arrs = zip (map paramName $ drop (1 + num_folds) $ lambdaParams lam) arrs + + isInvariantRes (_, pe, Var v) + | Just arr <- lookup v params_to_arrs = + Right (pe, arr) + isInvariantRes x = + Left x +liftIdentityStreaming _ _ _ _ = Skip + +-- | Remove all arguments to the map that are simply replicates. +-- These can be turned into free variables instead. +removeReplicateMapping :: TopDownRuleOp (Wise SOACS) +removeReplicateMapping vtable pat _ (Screma w form arrs) + | Just fun <- isMapSOAC form, + Just (bnds, fun', arrs') <- removeReplicateInput vtable fun arrs = Simplify $ do + forM_ bnds $ \(vs,cs,e) -> certifying cs $ letBindNames vs e + letBind pat $ Op $ Screma w (mapSOAC fun') arrs' +removeReplicateMapping _ _ _ _ = Skip + +-- | Like 'removeReplicateMapping', but for 'Scatter'. +removeReplicateWrite :: TopDownRuleOp (Wise SOACS) +removeReplicateWrite vtable pat _ (Scatter len lam ivs as) + | Just (bnds, lam', ivs') <- removeReplicateInput vtable lam ivs = Simplify $ do + forM_ bnds $ \(vs,cs,e) -> certifying cs $ letBindNames vs e + letBind pat $ Op $ Scatter len lam' ivs' as +removeReplicateWrite _ _ _ _ = Skip + +removeReplicateInput :: Aliased lore => + ST.SymbolTable lore + -> AST.Lambda lore -> [VName] + -> Maybe ([([VName], Certificates, AST.Exp lore)], + AST.Lambda lore, [VName]) +removeReplicateInput vtable fun arrs + | not $ null parameterBnds = do + let (arr_params', arrs') = unzip params_and_arrs + fun' = fun { lambdaParams = acc_params <> arr_params' } + return (parameterBnds, fun', arrs') + | otherwise = Nothing + + where params = lambdaParams fun + (acc_params, arr_params) = + splitAt (length params - length arrs) params + (params_and_arrs, parameterBnds) = + partitionEithers $ zipWith isReplicateAndNotConsumed arr_params arrs + + isReplicateAndNotConsumed p v + | Just (BasicOp (Replicate (Shape (_:ds)) e), v_cs) <- + ST.lookupExp v vtable, + not $ paramName p `nameIn` consumedByLambda fun = + Right ([paramName p], + v_cs, + case ds of + [] -> BasicOp $ SubExp e + _ -> BasicOp $ Replicate (Shape ds) e) + | otherwise = + Left (p, v) + +-- | Remove inputs that are not used inside the SOAC. +removeUnusedSOACInput :: TopDownRuleOp (Wise SOACS) +removeUnusedSOACInput _ pat _ (Screma w (ScremaForm scan reduce map_lam) arrs) + | (used,unused) <- partition usedInput params_and_arrs, + not (null unused) = Simplify $ do + let (used_params, used_arrs) = unzip used + map_lam' = map_lam { lambdaParams = used_params } + letBind pat $ Op $ Screma w (ScremaForm scan reduce map_lam') used_arrs + where params_and_arrs = zip (lambdaParams map_lam) arrs + used_in_body = freeIn $ lambdaBody map_lam + usedInput (param, _) = paramName param `nameIn` used_in_body +removeUnusedSOACInput _ _ _ _ = Skip + +removeDeadMapping :: BottomUpRuleOp (Wise SOACS) +removeDeadMapping (_, used) pat _ (Screma w form arrs) + | Just fun <- isMapSOAC form = + let ses = bodyResult $ lambdaBody fun + isUsed (bindee, _, _) = (`UT.used` used) $ patElemName bindee + (pat',ses', ts') = unzip3 $ filter isUsed $ + zip3 (patternElements pat) ses $ lambdaReturnType fun + fun' = fun { lambdaBody = (lambdaBody fun) { bodyResult = ses' } + , lambdaReturnType = ts' + } + in if pat /= Pattern [] pat' + then Simplify $ letBind (Pattern [] pat') $ Op $ Screma w (mapSOAC fun') arrs + else Skip +removeDeadMapping _ _ _ _ = Skip + +removeDuplicateMapOutput :: BottomUpRuleOp (Wise SOACS) +removeDuplicateMapOutput (_, used) pat _ (Screma w form arrs) + | Just fun <- isMapSOAC form = + let ses = bodyResult $ lambdaBody fun + ts = lambdaReturnType fun + pes = patternValueElements pat + ses_ts_pes = zip3 ses ts pes + (ses_ts_pes', copies) = + foldl checkForDuplicates (mempty,mempty) ses_ts_pes + in if null copies then Skip + else Simplify $ do + let (ses', ts', pes') = unzip3 ses_ts_pes' + pat' = Pattern [] pes' + fun' = fun { lambdaBody = (lambdaBody fun) { bodyResult = ses' } + , lambdaReturnType = ts' } + letBind pat' $ Op $ Screma w (mapSOAC fun') arrs + forM_ copies $ \(from,to) -> + if UT.isConsumed (patElemName to) used then + letBind (Pattern [] [to]) $ BasicOp $ Copy $ patElemName from + else + letBind (Pattern [] [to]) $ BasicOp $ SubExp $ Var $ patElemName from + where checkForDuplicates (ses_ts_pes',copies) (se,t,pe) + | Just (_,_,pe') <- find (\(x,_,_) -> x == se) ses_ts_pes' = + -- This subexp has been returned before, producing the + -- array pe'. + (ses_ts_pes', (pe', pe) : copies) + | otherwise = (ses_ts_pes' ++ [(se,t,pe)], copies) +removeDuplicateMapOutput _ _ _ _ = Skip + +-- Mapping some operations becomes an extension of that operation. +mapOpToOp :: BottomUpRuleOp (Wise SOACS) + +mapOpToOp (_, used) pat aux1 e + | Just (map_pe, cs, w, BasicOp (Reshape newshape reshape_arr), [p], [arr]) <- + isMapWithOp pat e, + paramName p == reshape_arr, + not $ UT.isConsumed (patElemName map_pe) used = Simplify $ do + let redim | isJust $ shapeCoercion newshape = DimCoercion w + | otherwise = DimNew w + certifying (stmAuxCerts aux1 <> cs) $ letBind pat $ + BasicOp $ Reshape (redim : newshape) arr + + | Just (_, cs, _, + BasicOp (Concat d arr arrs dw), ps, outer_arr : outer_arrs) <- + isMapWithOp pat e, + (arr:arrs) == map paramName ps = + Simplify $ certifying (stmAuxCerts aux1 <> cs) $ letBind pat $ + BasicOp $ Concat (d+1) outer_arr outer_arrs dw + + | Just (map_pe, cs, _, + BasicOp (Rearrange perm rearrange_arr), [p], [arr]) <- + isMapWithOp pat e, + paramName p == rearrange_arr, + not $ UT.isConsumed (patElemName map_pe) used = + Simplify $ certifying (stmAuxCerts aux1 <> cs) $ letBind pat $ + BasicOp $ Rearrange (0 : map (1+) perm) arr + + | Just (map_pe, cs, _, BasicOp (Rotate rots rotate_arr), [p], [arr]) <- + isMapWithOp pat e, + paramName p == rotate_arr, + not $ UT.isConsumed (patElemName map_pe) used = + Simplify $ certifying (stmAuxCerts aux1 <> cs) $ letBind pat $ + BasicOp $ Rotate (intConst Int32 0 : rots) arr + +mapOpToOp _ _ _ _ = Skip + +isMapWithOp :: PatternT dec + -> SOAC (Wise SOACS) + -> Maybe (PatElemT dec, Certificates, SubExp, + AST.Exp (Wise SOACS), [Param Type], [VName]) +isMapWithOp pat e + | Pattern [] [map_pe] <- pat, + Screma w form arrs <- e, + Just map_lam <- isMapSOAC form, + [Let (Pattern [] [pe]) aux2 e'] <- + stmsToList $ bodyStms $ lambdaBody map_lam, + [Var r] <- bodyResult $ lambdaBody map_lam, + r == patElemName pe = + Just (map_pe, stmAuxCerts aux2, w, e', lambdaParams map_lam, arrs) + | otherwise = Nothing + +-- | Some of the results of a reduction (or really: Redomap) may be +-- dead. We remove them here. The trick is that we need to look at +-- the data dependencies to see that the "dead" result is not +-- actually used for computing one of the live ones. +removeDeadReduction :: BottomUpRuleOp (Wise SOACS) +removeDeadReduction (_, used) pat aux (Screma w form arrs) + | Just ([Reduce comm redlam nes], maplam) <- isRedomapSOAC form, + not $ all (`UT.used` used) $ patternNames pat, -- Quick/cheap check + + let (red_pes, map_pes) = splitAt (length nes) $ patternElements pat, + let redlam_deps = dataDependencies $ lambdaBody redlam, + let redlam_res = bodyResult $ lambdaBody redlam, + let redlam_params = lambdaParams redlam, + let used_after = map snd $ filter ((`UT.used` used) . patElemName . fst) $ + zip red_pes redlam_params, + let necessary = findNecessaryForReturned (`elem` used_after) + (zip redlam_params $ redlam_res <> redlam_res) redlam_deps, + let alive_mask = map ((`nameIn` necessary) . paramName) redlam_params, + + not $ all (==True) alive_mask = Simplify $ do + + let fixDeadToNeutral lives ne = if lives then Nothing else Just ne + dead_fix = zipWith fixDeadToNeutral alive_mask nes + (used_red_pes, _, used_nes) = + unzip3 $ filter (\(_,x,_) -> paramName x `nameIn` necessary) $ + zip3 red_pes redlam_params nes + + let maplam' = removeLambdaResults (take (length nes) alive_mask) maplam + redlam' <- removeLambdaResults (take (length nes) alive_mask) <$> fixLambdaParams redlam (dead_fix++dead_fix) + + auxing aux $ letBind (Pattern [] $ used_red_pes ++ map_pes) $ + Op $ Screma w (redomapSOAC [Reduce comm redlam' used_nes] maplam') arrs + +removeDeadReduction _ _ _ _ = Skip + +-- | If we are writing to an array that is never used, get rid of it. +removeDeadWrite :: BottomUpRuleOp (Wise SOACS) +removeDeadWrite (_, used) pat _ (Scatter w fun arrs dests) = + let (i_ses, v_ses) = splitAt (length dests) $ bodyResult $ lambdaBody fun + (i_ts, v_ts) = splitAt (length dests) $ lambdaReturnType fun + isUsed (bindee, _, _, _, _, _) = (`UT.used` used) $ patElemName bindee + (pat', i_ses', v_ses', i_ts', v_ts', dests') = + unzip6 $ filter isUsed $ + zip6 (patternElements pat) i_ses v_ses i_ts v_ts dests + fun' = fun { lambdaBody = (lambdaBody fun) { bodyResult = i_ses' ++ v_ses' } + , lambdaReturnType = i_ts' ++ v_ts' + } + in if pat /= Pattern [] pat' + then Simplify $ letBind (Pattern [] pat') $ Op $ Scatter w fun' arrs dests' + else Skip +removeDeadWrite _ _ _ _ = Skip + +-- handles now concatenation of more than two arrays +fuseConcatScatter :: TopDownRuleOp (Wise SOACS) +fuseConcatScatter vtable pat _ (Scatter _ fun arrs dests) + | Just (ws@(w':_), xss, css) <- unzip3 <$> mapM isConcat arrs, + xivs <- transpose xss, + all (w'==) ws = Simplify $ do + let r = length xivs + fun2s <- mapM (\_ -> renameLambda fun) [1 .. r-1] + let fun_n = length $ lambdaReturnType fun + (fun_is, fun_vs) = unzip $ map (splitAt (fun_n `div` 2) . + bodyResult . lambdaBody ) (fun:fun2s) + (its, vts) = unzip $ replicate r $ + splitAt (fun_n `div` 2) $ lambdaReturnType fun + new_stmts = mconcat $ map (bodyStms . lambdaBody) (fun:fun2s) + let fun' = Lambda + { lambdaParams = mconcat $ map lambdaParams (fun:fun2s) + , lambdaBody = mkBody new_stmts $ + mix fun_is <> mix fun_vs + , lambdaReturnType = mix its <> mix vts + } + certifying (mconcat css) $ + letBind pat $ Op $ Scatter w' fun' (concat xivs) $ map (incWrites r) dests + where sizeOf :: VName -> Maybe SubExp + sizeOf x = arraySize 0 . ST.entryType <$> ST.lookup x vtable + mix = concat . transpose + incWrites r (w, n, a) = (w, n*r, a) -- ToDO: is it (n*r) or (n+r-1)?? + isConcat v = case ST.lookupExp v vtable of + Just (BasicOp (Concat 0 x ys _), cs) -> do + x_w <- sizeOf x + y_ws<- mapM sizeOf ys + guard $ all (x_w==) y_ws + return (x_w, x:ys, cs) + Just (BasicOp (Reshape reshape arr), cs) -> do + guard $ isJust $ shapeCoercion reshape + (a, b, cs') <- isConcat arr + return (a, b, cs <> cs') + _ -> Nothing + +fuseConcatScatter _ _ _ _ = Skip + +simplifyClosedFormReduce :: TopDownRuleOp (Wise SOACS) +simplifyClosedFormReduce _ pat _ (Screma (Constant w) form _) + | Just nes <- concatMap redNeutral . fst <$> isRedomapSOAC form, + zeroIsh w = + Simplify $ forM_ (zip (patternNames pat) nes) $ \(v, ne) -> + letBindNames [v] $ BasicOp $ SubExp ne +simplifyClosedFormReduce vtable pat _ (Screma _ form arrs) + | Just [Reduce _ red_fun nes] <- isReduceSOAC form = + Simplify $ foldClosedForm (`ST.lookupExp` vtable) pat red_fun nes arrs +simplifyClosedFormReduce _ _ _ _ = Skip + +-- For now we just remove singleton SOACs. +simplifyKnownIterationSOAC :: TopDownRuleOp (Wise SOACS) +simplifyKnownIterationSOAC _ pat _ (Screma (Constant k) + (ScremaForm scans reds map_lam) + arrs) + | oneIsh k = Simplify $ do + zipWithM_ bindMapParam (lambdaParams map_lam) arrs + (to_scan, to_red, map_res) <- splitAt3 (length scan_nes) (length red_nes) <$> + bodyBind (lambdaBody map_lam) + scan_res <- eLambda scan_lam $ map eSubExp $ scan_nes ++ to_scan + red_res <- eLambda red_lam $ map eSubExp $ red_nes ++ to_red + + zipWithM_ bindArrayResult scan_pes scan_res + zipWithM_ bindResult red_pes red_res + zipWithM_ bindArrayResult map_pes map_res + + where (Reduce _ red_lam red_nes) = singleReduce reds + (Scan scan_lam scan_nes) = singleScan scans + (scan_pes, red_pes, map_pes) = splitAt3 (length scan_nes) (length red_nes) $ + patternElements pat + bindMapParam p a = do + a_t <- lookupType a + letBindNames [paramName p] $ + BasicOp $ Index a $ fullSlice a_t [DimFix $ constant (0::Int32)] + bindArrayResult pe se = + letBindNames [patElemName pe] $ + BasicOp $ ArrayLit [se] $ rowType $ patElemType pe + bindResult pe se = + letBindNames [patElemName pe] $ BasicOp $ SubExp se + +simplifyKnownIterationSOAC _ pat _ (Stream (Constant k) form fold_lam arrs) + | oneIsh k = Simplify $ do + let nes = getStreamAccums form + (chunk_param, acc_params, slice_params) = + partitionChunkedFoldParameters (length nes) (lambdaParams fold_lam) + + letBindNames [paramName chunk_param] $ + BasicOp $ SubExp $ intConst Int32 1 + + forM_ (zip acc_params nes) $ \(p, ne) -> + letBindNames [paramName p] $ BasicOp $ SubExp ne + + forM_ (zip slice_params arrs) $ \(p, arr) -> + letBindNames [paramName p] $ BasicOp $ SubExp $ Var arr + + res <- bodyBind $ lambdaBody fold_lam + + forM_ (zip (patternNames pat) res) $ \(v, se) -> + letBindNames [v] $ BasicOp $ SubExp se + +simplifyKnownIterationSOAC _ _ _ _ = Skip + +data ArrayOp = ArrayIndexing Certificates VName (Slice SubExp) + | ArrayRearrange Certificates VName [Int] + | ArrayRotate Certificates VName [SubExp] + | ArrayVar Certificates VName -- ^ Never constructed. + deriving (Eq, Ord, Show) + +arrayOpArr :: ArrayOp -> VName +arrayOpArr (ArrayIndexing _ arr _) = arr +arrayOpArr (ArrayRearrange _ arr _) = arr +arrayOpArr (ArrayRotate _ arr _) = arr +arrayOpArr (ArrayVar _ arr) = arr + +arrayOpCerts :: ArrayOp -> Certificates +arrayOpCerts (ArrayIndexing cs _ _) = cs +arrayOpCerts (ArrayRearrange cs _ _) = cs +arrayOpCerts (ArrayRotate cs _ _) = cs +arrayOpCerts (ArrayVar cs _) = cs + +isArrayOp :: Certificates -> AST.Exp (Wise SOACS) -> Maybe ArrayOp +isArrayOp cs (BasicOp (Index arr slice)) = + Just $ ArrayIndexing cs arr slice +isArrayOp cs (BasicOp (Rearrange perm arr)) = + Just $ ArrayRearrange cs arr perm +isArrayOp cs (BasicOp (Rotate rots arr)) = + Just $ ArrayRotate cs arr rots +isArrayOp _ _ = + Nothing + +fromArrayOp :: ArrayOp -> (Certificates, AST.Exp (Wise SOACS)) +fromArrayOp (ArrayIndexing cs arr slice) = (cs, BasicOp $ Index arr slice) +fromArrayOp (ArrayRearrange cs arr perm) = (cs, BasicOp $ Rearrange perm arr) +fromArrayOp (ArrayRotate cs arr rots) = (cs, BasicOp $ Rotate rots arr) +fromArrayOp (ArrayVar cs arr) = (cs, BasicOp $ SubExp $ Var arr) + +arrayOps :: AST.Body (Wise SOACS) -> S.Set (AST.Pattern (Wise SOACS), ArrayOp) +arrayOps = mconcat . map onStm . stmsToList . bodyStms + where onStm (Let pat aux e) = + case isArrayOp (stmAuxCerts aux) e of + Just op -> S.singleton (pat, op) + Nothing -> execState (walkExpM walker e) mempty + onOp = execWriter . mapSOACM identitySOACMapper { mapOnSOACLambda = onLambda } + onLambda lam = do tell $ arrayOps $ lambdaBody lam + return lam + walker = identityWalker { walkOnBody = modify . (<>) . arrayOps + , walkOnOp = modify . (<>) . onOp } + +replaceArrayOps :: M.Map ArrayOp ArrayOp + -> AST.Body (Wise SOACS) -> AST.Body (Wise SOACS) +replaceArrayOps substs (Body _ stms res) = + mkBody (fmap onStm stms) res + where onStm (Let pat aux e) = + let (cs', e') = onExp (stmAuxCerts aux) e + in certify cs' $ mkLet (patternContextIdents pat) (patternValueIdents pat) e' + onExp cs e + | Just op <- isArrayOp cs e, + Just op' <- M.lookup op substs = + fromArrayOp op' + onExp cs e = (cs, mapExp mapper e) + mapper = identityMapper { mapOnBody = const $ return . replaceArrayOps substs + , mapOnOp = return . onOp } + onOp = runIdentity . mapSOACM identitySOACMapper { mapOnSOACLambda = return . onLambda } + onLambda lam = lam { lambdaBody = replaceArrayOps substs $ lambdaBody lam } + +-- Turn +-- +-- map (\i -> ... xs[i] ...) (iota n) +-- +-- into +-- +-- map (\i x -> ... x ...) (iota n) xs +-- +-- This is not because we want to encourage the map-iota pattern, but +-- it may be present in generated code. This is an unfortunately +-- expensive simplification rule, since it requires multiple passes +-- over the entire lambda body. It only handles the very simplest +-- case - if you find yourself planning to extend it to handle more +-- complex situations (rotate or whatnot), consider turning it into a +-- separate compiler pass instead. +simplifyMapIota :: TopDownRuleOp (Wise SOACS) +simplifyMapIota vtable pat _ (Screma w (ScremaForm scan reduce map_lam) arrs) + | Just (p, _) <- find isIota (zip (lambdaParams map_lam) arrs), + indexings <- filter (indexesWith (paramName p)) $ map snd $ S.toList $ + arrayOps $ lambdaBody map_lam, + not $ null indexings = Simplify $ do + -- For each indexing with iota, add the corresponding array to + -- the Screma, and construct a new lambda parameter. + (more_arrs, more_params, replacements) <- + unzip3 . catMaybes <$> mapM mapOverArr indexings + let substs = M.fromList $ zip indexings replacements + map_lam' = map_lam { lambdaParams = lambdaParams map_lam <> more_params + , lambdaBody = replaceArrayOps substs $ + lambdaBody map_lam + } + letBind pat $ Op $ Screma w (ScremaForm scan reduce map_lam') (arrs <> more_arrs) + where isIota (_, arr) = case ST.lookupBasicOp arr vtable of + Just (Iota _ (Constant o) (Constant s) _, _) -> + zeroIsh o && oneIsh s + _ -> False + + indexesWith v (ArrayIndexing cs arr (DimFix (Var i) : _)) + | arr `ST.elem` vtable, + all (`ST.elem` vtable) $ unCertificates cs = + i == v + indexesWith _ _ = False + + mapOverArr (ArrayIndexing cs arr slice) = do + arr_elem <- newVName $ baseString arr ++ "_elem" + arr_t <- lookupType arr + arr' <- if arraySize 0 arr_t == w + then return arr + else certifying cs $ letExp (baseString arr ++ "_prefix") $ + BasicOp $ Index arr $ + fullSlice arr_t [DimSlice (intConst Int32 0) w (intConst Int32 1)] + return $ Just (arr', + Param arr_elem (rowType arr_t), + ArrayIndexing cs arr_elem (drop 1 slice)) + + mapOverArr _ = return Nothing + +simplifyMapIota _ _ _ _ = Skip + +-- If a Screma's map function contains a transformation +-- (e.g. transpose) on a parameter, create a new parameter +-- corresponding to that transformation performed on the rows of the +-- full array. +moveTransformToInput :: TopDownRuleOp (Wise SOACS) +moveTransformToInput vtable pat _ (Screma w (ScremaForm scan reduce map_lam) arrs) + | ops <- map snd $ filter arrayIsMapParam $ S.toList $ arrayOps $ lambdaBody map_lam, + not $ null ops = Simplify $ do + (more_arrs, more_params, replacements) <- + unzip3 . catMaybes <$> mapM mapOverArr ops + + when (null more_arrs) cannotSimplify + + let substs = M.fromList $ zip ops replacements + map_lam' = map_lam { lambdaParams = lambdaParams map_lam <> more_params + , lambdaBody = replaceArrayOps substs $ + lambdaBody map_lam + } + + letBind pat $ Op $ Screma w (ScremaForm scan reduce map_lam') (arrs <> more_arrs) + + where map_param_names = map paramName (lambdaParams map_lam) + topLevelPattern = (`elem` fmap stmPattern (bodyStms (lambdaBody map_lam))) + onlyUsedOnce arr = + case filter ((arr `nameIn`) . freeIn) $ stmsToList $ bodyStms $ lambdaBody map_lam of + _ : _ : _ -> False + _ -> True + + -- It's not just about whether the array is a parameter; + -- everything else must be map-invariant. + arrayIsMapParam (pat', ArrayIndexing cs arr slice) = + arr `elem` map_param_names && + all (`ST.elem` vtable) (namesToList $ freeIn cs <> freeIn slice) && + not (null slice) && + (not (null $ sliceDims slice) || (topLevelPattern pat' && onlyUsedOnce arr)) + arrayIsMapParam (_, ArrayRearrange cs arr perm) = + arr `elem` map_param_names && + all (`ST.elem` vtable) (namesToList $ freeIn cs) && + not (null perm) + arrayIsMapParam (_, ArrayRotate cs arr rots) = + arr `elem` map_param_names && + all (`ST.elem` vtable) (namesToList $ freeIn cs <> freeIn rots) + arrayIsMapParam (_, ArrayVar{}) = + False + + mapOverArr op + | Just (_, arr) <- find ((==arrayOpArr op) . fst) (zip map_param_names arrs) = do + arr_t <- lookupType arr + let whole_dim = DimSlice (intConst Int32 0) (arraySize 0 arr_t) (intConst Int32 1) + arr_transformed <- certifying (arrayOpCerts op) $ + letExp (baseString arr ++ "_transformed") $ + case op of + ArrayIndexing _ _ slice -> + BasicOp $ Index arr $ whole_dim : slice + ArrayRearrange _ _ perm -> + BasicOp $ Rearrange (0 : map (+1) perm) arr + ArrayRotate _ _ rots -> + BasicOp $ Rotate (intConst Int32 0 : rots) arr + ArrayVar{} -> + BasicOp $ SubExp $ Var arr + arr_transformed_t <- lookupType arr_transformed + arr_transformed_row <- newVName $ baseString arr ++ "_transformed_row" + return $ Just (arr_transformed, + Param arr_transformed_row (rowType arr_transformed_t), + ArrayVar mempty arr_transformed_row) + + mapOverArr _ = return Nothing + +moveTransformToInput _ _ _ _ = + Skip diff --git a/src/Futhark/IR/SegOp.hs b/src/Futhark/IR/SegOp.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/IR/SegOp.hs @@ -0,0 +1,1177 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | Segmented operations. These correspond to perfect @map@ nests on +-- top of /something/, except that the @map@s are conceptually only +-- over @iota@s (so there will be explicit indexing inside them). +module Futhark.IR.SegOp + ( SegOp(..) + , SegVirt(..) + , segLevel + , segSpace + , typeCheckSegOp + , SegSpace(..) + , scopeOfSegSpace + , segSpaceDims + + -- * Details + , HistOp(..) + , histType + , SegBinOp(..) + , segBinOpResults + , segBinOpChunks + , KernelBody(..) + , aliasAnalyseKernelBody + , consumedInKernelBody + , ResultManifest(..) + , KernelResult(..) + , kernelResultSubExp + , SplitOrdering(..) + + -- ** Generic traversal + , SegOpMapper(..) + , identitySegOpMapper + , mapSegOpM + + -- * Simplification + , simplifySegOp + , HasSegOp(..) + , segOpRules + + -- * Memory + , segOpReturns + ) +where + +import Control.Monad.State.Strict +import Control.Monad.Writer hiding (mapM_) +import Control.Monad.Identity hiding (mapM_) +import Data.Bifunctor (first) +import qualified Data.Map.Strict as M +import Data.Maybe +import Data.List + (intersperse, foldl', partition, isPrefixOf, groupBy) + +import Futhark.IR +import qualified Futhark.Analysis.Alias as Alias +import qualified Futhark.Analysis.SymbolTable as ST +import qualified Futhark.Analysis.UsageTable as UT +import Futhark.Analysis.PrimExp.Convert +import qualified Futhark.Util.Pretty as PP +import Futhark.Util.Pretty + ((), (<+>), ppr, commasep, Pretty, parens, text) +import Futhark.Transform.Substitute +import Futhark.Transform.Rename +import Futhark.Optimise.Simplify.Lore +import Futhark.IR.Ranges + (Ranges, removeLambdaRanges, removeStmRanges, mkBodyRanges) +import Futhark.IR.Prop.Ranges +import Futhark.IR.Prop.Aliases +import Futhark.IR.Aliases + (Aliases, removeLambdaAliases, removeStmAliases) +import Futhark.IR.Mem +import qualified Futhark.TypeCheck as TC +import Futhark.Analysis.Metrics +import qualified Futhark.Analysis.Range as Range +import Futhark.Util (maybeNth, chunks) +import Futhark.Optimise.Simplify.Rule +import qualified Futhark.Optimise.Simplify.Engine as Engine +import Futhark.Tools + +-- | How an array is split into chunks. +data SplitOrdering = SplitContiguous + | SplitStrided SubExp + deriving (Eq, Ord, Show) + +instance FreeIn SplitOrdering where + freeIn' SplitContiguous = mempty + freeIn' (SplitStrided stride) = freeIn' stride + +instance Substitute SplitOrdering where + substituteNames _ SplitContiguous = + SplitContiguous + substituteNames subst (SplitStrided stride) = + SplitStrided $ substituteNames subst stride + +instance Rename SplitOrdering where + rename SplitContiguous = + pure SplitContiguous + rename (SplitStrided stride) = + SplitStrided <$> rename stride + +-- | An operator for 'SegHist'. +data HistOp lore = + HistOp { histWidth :: SubExp + , histRaceFactor :: SubExp + , histDest :: [VName] + , histNeutral :: [SubExp] + , histShape :: Shape + -- ^ In case this operator is semantically a vectorised + -- operator (corresponding to a perfect map nest in the + -- SOACS representation), these are the logical + -- "dimensions". This is used to generate more efficient + -- code. + , histOp :: Lambda lore + } + deriving (Eq, Ord, Show) + +-- | The type of a histogram produced by a 'HistOp'. This can be +-- different from the type of the 'histDest's in case we are +-- dealing with a segmented histogram. +histType :: HistOp lore -> [Type] +histType op = map ((`arrayOfRow` histWidth op) . + (`arrayOfShape` histShape op)) $ + lambdaReturnType $ histOp op + +-- | An operator for 'SegScan' and 'SegRed'. +data SegBinOp lore = + SegBinOp { segBinOpComm :: Commutativity + , segBinOpLambda :: Lambda lore + , segBinOpNeutral :: [SubExp] + , segBinOpShape :: Shape + -- ^ In case this operator is semantically a vectorised + -- operator (corresponding to a perfect map nest in the + -- SOACS representation), these are the logical + -- "dimensions". This is used to generate more efficient + -- code. + } + deriving (Eq, Ord, Show) + +-- | How many reduction results are produced by these 'SegBinOp's? +segBinOpResults :: [SegBinOp lore] -> Int +segBinOpResults = sum . map (length . segBinOpNeutral) + +-- | Split some list into chunks equal to the number of values +-- returned by each 'SegBinOp' +segBinOpChunks :: [SegBinOp lore] -> [a] -> [[a]] +segBinOpChunks = chunks . map (length . segBinOpNeutral) + +-- | The body of a 'SegOp'. +data KernelBody lore = KernelBody { kernelBodyLore :: BodyDec lore + , kernelBodyStms :: Stms lore + , kernelBodyResult :: [KernelResult] + } + +deriving instance Decorations lore => Ord (KernelBody lore) +deriving instance Decorations lore => Show (KernelBody lore) +deriving instance Decorations lore => Eq (KernelBody lore) + +-- | Metadata about whether there is a subtle point to this +-- 'KernelResult'. This is used to protect things like tiling, which +-- might otherwise be removed by the simplifier because they're +-- semantically redundant. This has no semantic effect and can be +-- ignored at code generation. +data ResultManifest + = ResultNoSimplify + -- ^ Don't simplify this one! + | ResultMaySimplify + -- ^ Go nuts. + | ResultPrivate + -- ^ The results produced are only used within the + -- same physical thread later on, and can thus be + -- kept in registers. + deriving (Eq, Show, Ord) + +-- | A 'KernelBody' does not return an ordinary 'Result'. Instead, it +-- returns a list of these. +data KernelResult = Returns ResultManifest SubExp + -- ^ Each "worker" in the kernel returns this. + -- Whether this is a result-per-thread or a + -- result-per-group depends on where the 'SegOp' occurs. + | WriteReturns + [SubExp] -- Size of array. Must match number of dims. + VName -- Which array + [(Slice SubExp, SubExp)] + -- Arbitrary number of index/value pairs. + | ConcatReturns + SplitOrdering -- Permuted? + SubExp -- The final size. + SubExp -- Per-thread/group (max) chunk size. + VName -- Chunk by this worker. + | TileReturns + [(SubExp, SubExp)] -- Total/tile for each dimension + VName -- Tile written by this worker. + -- The TileReturns must not expect more than one + -- result to be written per physical thread. + deriving (Eq, Show, Ord) + +-- | Get the root t'SubExp' corresponding values for a 'KernelResult'. +kernelResultSubExp :: KernelResult -> SubExp +kernelResultSubExp (Returns _ se) = se +kernelResultSubExp (WriteReturns _ arr _) = Var arr +kernelResultSubExp (ConcatReturns _ _ _ v) = Var v +kernelResultSubExp (TileReturns _ v) = Var v + +instance FreeIn KernelResult where + freeIn' (Returns _ what) = freeIn' what + freeIn' (WriteReturns rws arr res) = freeIn' rws <> freeIn' arr <> freeIn' res + freeIn' (ConcatReturns o w per_thread_elems v) = + freeIn' o <> freeIn' w <> freeIn' per_thread_elems <> freeIn' v + freeIn' (TileReturns dims v) = + freeIn' dims <> freeIn' v + +instance ASTLore lore => FreeIn (KernelBody lore) where + freeIn' (KernelBody dec stms res) = + fvBind bound_in_stms $ freeIn' dec <> freeIn' stms <> freeIn' res + where bound_in_stms = foldMap boundByStm stms + +instance ASTLore lore => Substitute (KernelBody lore) where + substituteNames subst (KernelBody dec stms res) = + KernelBody + (substituteNames subst dec) + (substituteNames subst stms) + (substituteNames subst res) + +instance Substitute KernelResult where + substituteNames subst (Returns manifest se) = + Returns manifest (substituteNames subst se) + substituteNames subst (WriteReturns rws arr res) = + WriteReturns + (substituteNames subst rws) (substituteNames subst arr) + (substituteNames subst res) + substituteNames subst (ConcatReturns o w per_thread_elems v) = + ConcatReturns + (substituteNames subst o) + (substituteNames subst w) + (substituteNames subst per_thread_elems) + (substituteNames subst v) + substituteNames subst (TileReturns dims v) = + TileReturns (substituteNames subst dims) (substituteNames subst v) + +instance ASTLore lore => Rename (KernelBody lore) where + rename (KernelBody dec stms res) = do + dec' <- rename dec + renamingStms stms $ \stms' -> + KernelBody dec' stms' <$> rename res + +instance Rename KernelResult where + rename = substituteRename + +-- | Perform alias analysis on a 'KernelBody'. +aliasAnalyseKernelBody :: (ASTLore lore, + CanBeAliased (Op lore)) => + KernelBody lore + -> KernelBody (Aliases lore) +aliasAnalyseKernelBody (KernelBody dec stms res) = + let Body dec' stms' _ = Alias.analyseBody mempty $ Body dec stms [] + in KernelBody dec' stms' res + +removeKernelBodyAliases :: CanBeAliased (Op lore) => + KernelBody (Aliases lore) -> KernelBody lore +removeKernelBodyAliases (KernelBody (_, dec) stms res) = + KernelBody dec (fmap removeStmAliases stms) res + +addKernelBodyRanges :: (ASTLore lore, CanBeRanged (Op lore)) => + KernelBody lore -> Range.RangeM (KernelBody (Ranges lore)) +addKernelBodyRanges (KernelBody dec stms res) = + Range.analyseStms stms $ \stms' -> do + let dec' = (mkBodyRanges stms $ map kernelResultSubExp res, dec) + return $ KernelBody dec' stms' res + +removeKernelBodyRanges :: CanBeRanged (Op lore) => + KernelBody (Ranges lore) -> KernelBody lore +removeKernelBodyRanges (KernelBody (_, dec) stms res) = + KernelBody dec (fmap removeStmRanges stms) res + +removeKernelBodyWisdom :: CanBeWise (Op lore) => + KernelBody (Wise lore) -> KernelBody lore +removeKernelBodyWisdom (KernelBody dec stms res) = + let Body dec' stms' _ = removeBodyWisdom $ Body dec stms [] + in KernelBody dec' stms' res + +-- | The variables consumed in the kernel body. +consumedInKernelBody :: Aliased lore => + KernelBody lore -> Names +consumedInKernelBody (KernelBody dec stms res) = + consumedInBody (Body dec stms []) <> mconcat (map consumedByReturn res) + where consumedByReturn (WriteReturns _ a _) = oneName a + consumedByReturn _ = mempty + +checkKernelBody :: TC.Checkable lore => + [Type] -> KernelBody (Aliases lore) -> TC.TypeM lore () +checkKernelBody ts (KernelBody (_, dec) stms kres) = do + TC.checkBodyLore dec + TC.checkStms stms $ do + unless (length ts == length kres) $ + TC.bad $ TC.TypeError $ "Kernel return type is " ++ prettyTuple ts ++ + ", but body returns " ++ show (length kres) ++ " values." + zipWithM_ checkKernelResult kres ts + + where checkKernelResult (Returns _ what) t = + TC.require [t] what + checkKernelResult (WriteReturns rws arr res) t = do + mapM_ (TC.require [Prim int32]) rws + arr_t <- lookupType arr + forM_ res $ \(slice, e) -> do + mapM_ (traverse $ TC.require [Prim int32]) slice + TC.require [t] e + unless (arr_t == t `arrayOfShape` Shape rws) $ + TC.bad $ TC.TypeError $ "WriteReturns returning " ++ + pretty e ++ " of type " ++ pretty t ++ ", shape=" ++ pretty rws ++ + ", but destination array has type " ++ pretty arr_t + TC.consume =<< TC.lookupAliases arr + checkKernelResult (ConcatReturns o w per_thread_elems v) t = do + case o of + SplitContiguous -> return () + SplitStrided stride -> TC.require [Prim int32] stride + TC.require [Prim int32] w + TC.require [Prim int32] per_thread_elems + vt <- lookupType v + unless (vt == t `arrayOfRow` arraySize 0 vt) $ + TC.bad $ TC.TypeError $ "Invalid type for ConcatReturns " ++ pretty v + checkKernelResult (TileReturns dims v) t = do + forM_ dims $ \(dim, tile) -> do + TC.require [Prim int32] dim + TC.require [Prim int32] tile + vt <- lookupType v + unless (vt == t `arrayOfShape` Shape (map snd dims)) $ + TC.bad $ TC.TypeError $ "Invalid type for TileReturns " ++ pretty v + +kernelBodyMetrics :: OpMetrics (Op lore) => KernelBody lore -> MetricsM () +kernelBodyMetrics = mapM_ stmMetrics . kernelBodyStms + +instance PrettyLore lore => Pretty (KernelBody lore) where + ppr (KernelBody _ stms res) = + PP.stack (map ppr (stmsToList stms)) + text "return" <+> PP.braces (PP.commasep $ map ppr res) + +instance Pretty KernelResult where + ppr (Returns ResultNoSimplify what) = + text "returns (manifest)" <+> ppr what + ppr (Returns ResultPrivate what) = + text "returns (private)" <+> ppr what + ppr (Returns ResultMaySimplify what) = + text "returns" <+> ppr what + ppr (WriteReturns rws arr res) = + ppr arr <+> text "with" <+> PP.apply (map ppRes res) + where ppRes (is, e) = + PP.brackets (PP.commasep $ zipWith f is rws) <+> text "<-" <+> ppr e + f i rw = ppr i <+> text "<" <+> ppr rw + ppr (ConcatReturns o w per_thread_elems v) = + text "concat" <> suff <> + parens (commasep [ppr w, ppr per_thread_elems]) <+> ppr v + where suff = case o of SplitContiguous -> mempty + SplitStrided stride -> text "Strided" <> parens (ppr stride) + ppr (TileReturns dims v) = + text "tile" <> + parens (commasep $ map onDim dims) <+> ppr v + where onDim (dim, tile) = ppr dim <+> text "/" <+> ppr tile + + +-- | Do we need group-virtualisation when generating code for the +-- segmented operation? In most cases, we do, but for some simple +-- kernels, we compute the full number of groups in advance, and then +-- virtualisation is an unnecessary (but generally very small) +-- overhead. This only really matters for fairly trivial but very +-- wide @map@ kernels where each thread performs constant-time work on +-- scalars. +data SegVirt + = SegVirt + | SegNoVirt + | SegNoVirtFull + -- ^ Not only do we not need virtualisation, but we _guarantee_ + -- that all physical threads participate in the work. This can + -- save some checks in code generation. + deriving (Eq, Ord, Show) + +-- | Index space of a 'SegOp'. +data SegSpace = SegSpace { segFlat :: VName + -- ^ Flat physical index corresponding to the + -- dimensions (at code generation used for a + -- thread ID or similar). + , unSegSpace :: [(VName, SubExp)] + } + deriving (Eq, Ord, Show) + + +-- | The sizes spanned by the indexes of the 'SegSpace'. +segSpaceDims :: SegSpace -> [SubExp] +segSpaceDims (SegSpace _ space) = map snd space + +-- | A 'Scope' containing all the identifiers brought into scope by +-- this 'SegSpace'. +scopeOfSegSpace :: SegSpace -> Scope lore +scopeOfSegSpace (SegSpace phys space) = + M.fromList $ zip (phys : map fst space) $ repeat $ IndexName Int32 + +checkSegSpace :: TC.Checkable lore => SegSpace -> TC.TypeM lore () +checkSegSpace (SegSpace _ dims) = + mapM_ (TC.require [Prim int32] . snd) dims + +-- | A 'SegOp' is semantically a perfectly nested stack of maps, on +-- top of some bottommost computation (scalar computation, reduction, +-- scan, or histogram). The 'SegSpace' encodes the original map +-- structure. +-- +-- All 'SegOp's are parameterised by the representation of their body, +-- as well as a *level*. The *level* is a representation-specific bit +-- of information. For example, in GPU backends, it is used to +-- indicate whether the 'SegOp' is expected to run at the thread-level +-- or the group-level. +data SegOp lvl lore + = SegMap lvl SegSpace [Type] (KernelBody lore) + | SegRed lvl SegSpace [SegBinOp lore] [Type] (KernelBody lore) + -- ^ The KernelSpace must always have at least two dimensions, + -- implying that the result of a SegRed is always an array. + | SegScan lvl SegSpace [SegBinOp lore] [Type] (KernelBody lore) + | SegHist lvl SegSpace [HistOp lore] [Type] (KernelBody lore) + deriving (Eq, Ord, Show) + +-- | The level of a 'SegOp'. +segLevel :: SegOp lvl lore -> lvl +segLevel (SegMap lvl _ _ _) = lvl +segLevel (SegRed lvl _ _ _ _) = lvl +segLevel (SegScan lvl _ _ _ _) = lvl +segLevel (SegHist lvl _ _ _ _) = lvl + +-- | The space of a 'SegOp'. +segSpace :: SegOp lvl lore -> SegSpace +segSpace (SegMap _ lvl _ _) = lvl +segSpace (SegRed _ lvl _ _ _) = lvl +segSpace (SegScan _ lvl _ _ _) = lvl +segSpace (SegHist _ lvl _ _ _) = lvl + +segResultShape :: SegSpace -> Type -> KernelResult -> Type +segResultShape _ t (WriteReturns rws _ _) = + t `arrayOfShape` Shape rws +segResultShape space t (Returns _ _) = + foldr (flip arrayOfRow) t $ segSpaceDims space +segResultShape _ t (ConcatReturns _ w _ _) = + t `arrayOfRow` w +segResultShape _ t (TileReturns dims _) = + t `arrayOfShape` Shape (map fst dims) + +-- | The return type of a 'SegOp'. +segOpType :: SegOp lvl lore -> [Type] +segOpType (SegMap _ space ts kbody) = + zipWith (segResultShape space) ts $ kernelBodyResult kbody +segOpType (SegRed _ space reds ts kbody) = + red_ts ++ + zipWith (segResultShape space) map_ts + (drop (length red_ts) $ kernelBodyResult kbody) + where map_ts = drop (length red_ts) ts + segment_dims = init $ segSpaceDims space + red_ts = do + op <- reds + let shape = Shape segment_dims <> segBinOpShape op + map (`arrayOfShape` shape) (lambdaReturnType $ segBinOpLambda op) +segOpType (SegScan _ space scans ts kbody) = + scan_ts ++ + zipWith (segResultShape space) map_ts + (drop (length scan_ts) $ kernelBodyResult kbody) + where map_ts = drop (length scan_ts) ts + scan_ts = do + op <- scans + let shape = Shape (segSpaceDims space) <> segBinOpShape op + map (`arrayOfShape` shape) (lambdaReturnType $ segBinOpLambda op) +segOpType (SegHist _ space ops _ _) = do + op <- ops + let shape = Shape (segment_dims <> [histWidth op]) <> histShape op + map (`arrayOfShape` shape) (lambdaReturnType $ histOp op) + where dims = segSpaceDims space + segment_dims = init dims + +instance TypedOp (SegOp lvl lore) where + opType = pure . staticShapes . segOpType + +instance (ASTLore lore, Aliased lore, ASTConstraints lvl) => + AliasedOp (SegOp lvl lore) where + opAliases = map (const mempty) . segOpType + + consumedInOp (SegMap _ _ _ kbody) = + consumedInKernelBody kbody + consumedInOp (SegRed _ _ _ _ kbody) = + consumedInKernelBody kbody + consumedInOp (SegScan _ _ _ _ kbody) = + consumedInKernelBody kbody + consumedInOp (SegHist _ _ ops _ kbody) = + namesFromList (concatMap histDest ops) <> consumedInKernelBody kbody + +-- | Type check a 'SegOp', given a checker for its level. +typeCheckSegOp :: TC.Checkable lore => + (lvl -> TC.TypeM lore ()) + -> SegOp lvl (Aliases lore) -> TC.TypeM lore () +typeCheckSegOp checkLvl (SegMap lvl space ts kbody) = do + checkLvl lvl + checkScanRed space [] ts kbody + +typeCheckSegOp checkLvl (SegRed lvl space reds ts body) = do + checkLvl lvl + checkScanRed space reds' ts body + where reds' = zip3 + (map segBinOpLambda reds) + (map segBinOpNeutral reds) + (map segBinOpShape reds) + +typeCheckSegOp checkLvl (SegScan lvl space scans ts body) = do + checkLvl lvl + checkScanRed space scans' ts body + where scans' = zip3 + (map segBinOpLambda scans) + (map segBinOpNeutral scans) + (map segBinOpShape scans) + +typeCheckSegOp checkLvl (SegHist lvl space ops ts kbody) = do + checkLvl lvl + checkSegSpace space + mapM_ TC.checkType ts + + TC.binding (scopeOfSegSpace space) $ do + nes_ts <- forM ops $ \(HistOp dest_w rf dests nes shape op) -> do + TC.require [Prim int32] dest_w + TC.require [Prim int32] rf + nes' <- mapM TC.checkArg nes + mapM_ (TC.require [Prim int32]) $ shapeDims shape + + -- Operator type must match the type of neutral elements. + let stripVecDims = stripArray $ shapeRank shape + TC.checkLambda op $ map (TC.noArgAliases . first stripVecDims) $ nes' ++ nes' + let nes_t = map TC.argType nes' + unless (nes_t == lambdaReturnType op) $ + TC.bad $ TC.TypeError $ "SegHist operator has return type " ++ + prettyTuple (lambdaReturnType op) ++ " but neutral element has type " ++ + prettyTuple nes_t + + -- Arrays must have proper type. + let dest_shape = Shape (segment_dims <> [dest_w]) <> shape + forM_ (zip nes_t dests) $ \(t, dest) -> do + TC.requireI [t `arrayOfShape` dest_shape] dest + TC.consume =<< TC.lookupAliases dest + + return $ map (`arrayOfShape` shape) nes_t + + checkKernelBody ts kbody + + -- Return type of bucket function must be an index for each + -- operation followed by the values to write. + let bucket_ret_t = replicate (length ops) (Prim int32) ++ concat nes_ts + unless (bucket_ret_t == ts) $ + TC.bad $ TC.TypeError $ "SegHist body has return type " ++ + prettyTuple ts ++ " but should have type " ++ + prettyTuple bucket_ret_t + + where segment_dims = init $ segSpaceDims space + +checkScanRed :: TC.Checkable lore => + SegSpace + -> [(Lambda (Aliases lore), [SubExp], Shape)] + -> [Type] + -> KernelBody (Aliases lore) + -> TC.TypeM lore () +checkScanRed space ops ts kbody = do + checkSegSpace space + mapM_ TC.checkType ts + + TC.binding (scopeOfSegSpace space) $ do + ne_ts <- forM ops $ \(lam, nes, shape) -> do + mapM_ (TC.require [Prim int32]) $ shapeDims shape + nes' <- mapM TC.checkArg nes + + -- Operator type must match the type of neutral elements. + TC.checkLambda lam $ map TC.noArgAliases $ nes' ++ nes' + let nes_t = map TC.argType nes' + + unless (lambdaReturnType lam == nes_t) $ + TC.bad $ TC.TypeError "wrong type for operator or neutral elements." + + return $ map (`arrayOfShape` shape) nes_t + + let expecting = concat ne_ts + got = take (length expecting) ts + unless (expecting == got) $ + TC.bad $ TC.TypeError $ + "Wrong return for body (does not match neutral elements; expected " ++ + pretty expecting ++ "; found " ++ + pretty got ++ ")" + + checkKernelBody ts kbody + +-- | Like 'Mapper', but just for 'SegOp's. +data SegOpMapper lvl flore tlore m = SegOpMapper { + mapOnSegOpSubExp :: SubExp -> m SubExp + , mapOnSegOpLambda :: Lambda flore -> m (Lambda tlore) + , mapOnSegOpBody :: KernelBody flore -> m (KernelBody tlore) + , mapOnSegOpVName :: VName -> m VName + , mapOnSegOpLevel :: lvl -> m lvl + } + +-- | A mapper that simply returns the 'SegOp' verbatim. +identitySegOpMapper :: Monad m => SegOpMapper lvl lore lore m +identitySegOpMapper = SegOpMapper { mapOnSegOpSubExp = return + , mapOnSegOpLambda = return + , mapOnSegOpBody = return + , mapOnSegOpVName = return + , mapOnSegOpLevel = return + } + +mapOnSegSpace :: Monad f => + SegOpMapper lvl flore tlore f -> SegSpace -> f SegSpace +mapOnSegSpace tv (SegSpace phys dims) = + SegSpace phys <$> traverse (traverse $ mapOnSegOpSubExp tv) dims + +mapSegBinOp :: Monad m => + SegOpMapper lvl flore tlore m + -> SegBinOp flore -> m (SegBinOp tlore) +mapSegBinOp tv (SegBinOp comm red_op nes shape) = + SegBinOp comm + <$> mapOnSegOpLambda tv red_op + <*> mapM (mapOnSegOpSubExp tv) nes + <*> (Shape <$> mapM (mapOnSegOpSubExp tv) (shapeDims shape)) + +-- | Apply a 'SegOpMapper' to the given 'SegOp'. +mapSegOpM :: (Applicative m, Monad m) => + SegOpMapper lvl flore tlore m + -> SegOp lvl flore -> m (SegOp lvl tlore) +mapSegOpM tv (SegMap lvl space ts body) = + SegMap + <$> mapOnSegOpLevel tv lvl + <*> mapOnSegSpace tv space + <*> mapM (mapOnSegOpType tv) ts + <*> mapOnSegOpBody tv body +mapSegOpM tv (SegRed lvl space reds ts lam) = + SegRed + <$> mapOnSegOpLevel tv lvl + <*> mapOnSegSpace tv space + <*> mapM (mapSegBinOp tv) reds + <*> mapM (mapOnType $ mapOnSegOpSubExp tv) ts + <*> mapOnSegOpBody tv lam +mapSegOpM tv (SegScan lvl space scans ts body) = + SegScan + <$> mapOnSegOpLevel tv lvl + <*> mapOnSegSpace tv space + <*> mapM (mapSegBinOp tv) scans + <*> mapM (mapOnType $ mapOnSegOpSubExp tv) ts + <*> mapOnSegOpBody tv body +mapSegOpM tv (SegHist lvl space ops ts body) = + SegHist + <$> mapOnSegOpLevel tv lvl + <*> mapOnSegSpace tv space + <*> mapM onHistOp ops + <*> mapM (mapOnType $ mapOnSegOpSubExp tv) ts + <*> mapOnSegOpBody tv body + where onHistOp (HistOp w rf arrs nes shape op) = + HistOp <$> mapOnSegOpSubExp tv w + <*> mapOnSegOpSubExp tv rf + <*> mapM (mapOnSegOpVName tv) arrs + <*> mapM (mapOnSegOpSubExp tv) nes + <*> (Shape <$> mapM (mapOnSegOpSubExp tv) (shapeDims shape)) + <*> mapOnSegOpLambda tv op + +mapOnSegOpType :: Monad m => + SegOpMapper lvl flore tlore m -> Type -> m Type +mapOnSegOpType _tv (Prim pt) = pure $ Prim pt +mapOnSegOpType tv (Array pt shape u) = Array pt <$> f shape <*> pure u + where f (Shape dims) = Shape <$> mapM (mapOnSegOpSubExp tv) dims +mapOnSegOpType _tv (Mem s) = pure $ Mem s + +instance (ASTLore lore, Substitute lvl) => + Substitute (SegOp lvl lore) where + substituteNames subst = runIdentity . mapSegOpM substitute + where substitute = + SegOpMapper { mapOnSegOpSubExp = return . substituteNames subst + , mapOnSegOpLambda = return . substituteNames subst + , mapOnSegOpBody = return . substituteNames subst + , mapOnSegOpVName = return . substituteNames subst + , mapOnSegOpLevel = return . substituteNames subst + } + +instance (ASTLore lore, ASTConstraints lvl) => + Rename (SegOp lvl lore) where + rename = mapSegOpM renamer + where renamer = SegOpMapper rename rename rename rename rename + +instance (ASTLore lore, FreeIn (LParamInfo lore), FreeIn lvl) => + FreeIn (SegOp lvl lore) where + freeIn' e = flip execState mempty $ mapSegOpM free e + where walk f x = modify (<>f x) >> return x + free = SegOpMapper { mapOnSegOpSubExp = walk freeIn' + , mapOnSegOpLambda = walk freeIn' + , mapOnSegOpBody = walk freeIn' + , mapOnSegOpVName = walk freeIn' + , mapOnSegOpLevel = walk freeIn' + } + +instance OpMetrics (Op lore) => OpMetrics (SegOp lvl lore) where + opMetrics (SegMap _ _ _ body) = + inside "SegMap" $ kernelBodyMetrics body + opMetrics (SegRed _ _ reds _ body) = + inside "SegRed" $ do mapM_ (lambdaMetrics . segBinOpLambda) reds + kernelBodyMetrics body + opMetrics (SegScan _ _ scans _ body) = + inside "SegScan" $ do mapM_ (lambdaMetrics . segBinOpLambda) scans + kernelBodyMetrics body + opMetrics (SegHist _ _ ops _ body) = + inside "SegHist" $ do mapM_ (lambdaMetrics . histOp) ops + kernelBodyMetrics body + +instance Pretty SegSpace where + ppr (SegSpace phys dims) = parens (commasep $ do (i,d) <- dims + return $ ppr i <+> "<" <+> ppr d) <+> + parens (text "~" <> ppr phys) + +instance PrettyLore lore => Pretty (SegBinOp lore) where + ppr (SegBinOp comm lam nes shape) = + PP.braces (PP.commasep $ map ppr nes) <> PP.comma + ppr shape <> PP.comma + comm' <> ppr lam + where comm' = case comm of Commutative -> text "commutative " + Noncommutative -> mempty + +instance (PrettyLore lore, PP.Pretty lvl) => PP.Pretty (SegOp lvl lore) where + ppr (SegMap lvl space ts body) = + text "segmap" <> ppr lvl + PP.align (ppr space) <+> + PP.colon <+> ppTuple' ts <+> PP.nestedBlock "{" "}" (ppr body) + + ppr (SegRed lvl space reds ts body) = + text "segred" <> ppr lvl + PP.parens (PP.braces (mconcat $ intersperse (PP.comma <> PP.line) $ map ppr reds)) + PP.align (ppr space) <+> PP.colon <+> ppTuple' ts <+> + PP.nestedBlock "{" "}" (ppr body) + + ppr (SegScan lvl space scans ts body) = + text "segscan" <> ppr lvl + PP.parens (PP.braces (mconcat $ intersperse (PP.comma <> PP.line) $ map ppr scans)) + PP.align (ppr space) <+> PP.colon <+> ppTuple' ts <+> + PP.nestedBlock "{" "}" (ppr body) + + ppr (SegHist lvl space ops ts body) = + text "seghist" <> ppr lvl + ppr lvl + PP.parens (PP.braces (mconcat $ intersperse (PP.comma <> PP.line) $ map ppOp ops)) + PP.align (ppr space) <+> PP.colon <+> ppTuple' ts <+> + PP.nestedBlock "{" "}" (ppr body) + where ppOp (HistOp w rf dests nes shape op) = + ppr w <> PP.comma <+> ppr rf <> PP.comma + PP.braces (PP.commasep $ map ppr dests) <> PP.comma + PP.braces (PP.commasep $ map ppr nes) <> PP.comma + ppr shape <> PP.comma + ppr op + +instance (ASTLore inner, ASTConstraints lvl) => + RangedOp (SegOp lvl inner) where + opRanges op = replicate (length $ segOpType op) unknownRange + +instance (ASTLore lore, CanBeRanged (Op lore), ASTConstraints lvl) => + CanBeRanged (SegOp lvl lore) where + type OpWithRanges (SegOp lvl lore) = SegOp lvl (Ranges lore) + + removeOpRanges = runIdentity . mapSegOpM remove + where remove = SegOpMapper return (return . removeLambdaRanges) + (return . removeKernelBodyRanges) return return + addOpRanges = Range.runRangeM . mapSegOpM add + where add = SegOpMapper return Range.analyseLambda + addKernelBodyRanges return return + +instance (ASTLore lore, ASTLore (Aliases lore), + CanBeAliased (Op lore), ASTConstraints lvl) => + CanBeAliased (SegOp lvl lore) where + type OpWithAliases (SegOp lvl lore) = SegOp lvl (Aliases lore) + + addOpAliases = runIdentity . mapSegOpM alias + where alias = SegOpMapper return (return . Alias.analyseLambda) + (return . aliasAnalyseKernelBody) return return + + removeOpAliases = runIdentity . mapSegOpM remove + where remove = SegOpMapper return (return . removeLambdaAliases) + (return . removeKernelBodyAliases) return return + +instance (CanBeWise (Op lore), ASTLore lore, ASTConstraints lvl) => + CanBeWise (SegOp lvl lore) where + type OpWithWisdom (SegOp lvl lore) = SegOp lvl (Wise lore) + + removeOpWisdom = runIdentity . mapSegOpM remove + where remove = SegOpMapper return + (return . removeLambdaWisdom) + (return . removeKernelBodyWisdom) + return return + +instance ASTLore lore => ST.IndexOp (SegOp lvl lore) where + indexOp vtable k (SegMap _ space _ kbody) is = do + Returns ResultMaySimplify se <- maybeNth k $ kernelBodyResult kbody + guard $ length gtids <= length is + let idx_table = M.fromList $ zip gtids $ map (ST.Indexed mempty) is + idx_table' = foldl expandIndexedTable idx_table $ kernelBodyStms kbody + case se of + Var v -> M.lookup v idx_table' + _ -> Nothing + + where (gtids, _) = unzip $ unSegSpace space + -- Indexes in excess of what is used to index through the + -- segment dimensions. + excess_is = drop (length gtids) is + + expandIndexedTable table stm + | [v] <- patternNames $ stmPattern stm, + Just (pe,cs) <- + runWriterT $ primExpFromExp (asPrimExp table) $ stmExp stm = + M.insert v (ST.Indexed (stmCerts stm <> cs) pe) table + + | [v] <- patternNames $ stmPattern stm, + BasicOp (Index arr slice) <- stmExp stm, + length (sliceDims slice) == length excess_is, + arr `ST.elem` vtable, + Just (slice', cs) <- asPrimExpSlice table slice = + let idx = ST.IndexedArray (stmCerts stm <> cs) + arr (fixSlice slice' excess_is) + in M.insert v idx table + + | otherwise = + table + + asPrimExpSlice table = + runWriterT . mapM (traverse (primExpFromSubExpM (asPrimExp table))) + + asPrimExp table v + | Just (ST.Indexed cs e) <- M.lookup v table = tell cs >> return e + | Just (Prim pt) <- ST.lookupType v vtable = + return $ LeafExp v pt + | otherwise = lift Nothing + + indexOp _ _ _ _ = Nothing + +instance (ASTLore lore, ASTConstraints lvl) => + IsOp (SegOp lvl lore) where + cheapOp _ = False + safeOp _ = True + +--- Simplification + +instance Engine.Simplifiable SplitOrdering where + simplify SplitContiguous = + return SplitContiguous + simplify (SplitStrided stride) = + SplitStrided <$> Engine.simplify stride + +instance Engine.Simplifiable SegSpace where + simplify (SegSpace phys dims) = + SegSpace phys <$> mapM (traverse Engine.simplify) dims + +instance Engine.Simplifiable KernelResult where + simplify (Returns manifest what) = + Returns manifest <$> Engine.simplify what + simplify (WriteReturns ws a res) = + WriteReturns <$> Engine.simplify ws <*> Engine.simplify a <*> Engine.simplify res + simplify (ConcatReturns o w pte what) = + ConcatReturns + <$> Engine.simplify o + <*> Engine.simplify w + <*> Engine.simplify pte + <*> Engine.simplify what + simplify (TileReturns dims what) = + TileReturns <$> Engine.simplify dims <*> Engine.simplify what + +mkWiseKernelBody :: (ASTLore lore, CanBeWise (Op lore)) => + BodyDec lore -> Stms (Wise lore) -> [KernelResult] -> KernelBody (Wise lore) +mkWiseKernelBody dec bnds res = + let Body dec' _ _ = mkWiseBody dec bnds res_vs + in KernelBody dec' bnds res + where res_vs = map kernelResultSubExp res + +mkKernelBodyM :: MonadBinder m => + Stms (Lore m) -> [KernelResult] + -> m (KernelBody (Lore m)) +mkKernelBodyM stms kres = do + Body dec' _ _ <- mkBodyM stms res_ses + return $ KernelBody dec' stms kres + where res_ses = map kernelResultSubExp kres + +simplifyKernelBody :: (Engine.SimplifiableLore lore, BodyDec lore ~ ()) => + SegSpace -> KernelBody lore + -> Engine.SimpleM lore (KernelBody (Wise lore), Stms (Wise lore)) +simplifyKernelBody space (KernelBody _ stms res) = do + par_blocker <- Engine.asksEngineEnv $ Engine.blockHoistPar . Engine.envHoistBlockers + + ((body_stms, body_res), hoisted) <- + Engine.localVtable (<>scope_vtable) $ + Engine.localVtable (\vtable -> vtable { ST.simplifyMemory = True }) $ + Engine.blockIf (Engine.hasFree bound_here + `Engine.orIf` Engine.isOp + `Engine.orIf` par_blocker + `Engine.orIf` Engine.isConsumed) $ + Engine.simplifyStms stms $ do + res' <- Engine.localVtable (ST.hideCertified $ namesFromList $ M.keys $ scopeOf stms) $ + mapM Engine.simplify res + return ((res', UT.usages $ freeIn res'), mempty) + + return (mkWiseKernelBody () body_stms body_res, hoisted) + + where scope_vtable = ST.fromScope $ scopeOfSegSpace space + bound_here = namesFromList $ M.keys $ scopeOfSegSpace space + +simplifySegBinOp :: Engine.SimplifiableLore lore => + SegBinOp lore + -> Engine.SimpleM lore (SegBinOp (Wise lore), Stms (Wise lore)) +simplifySegBinOp (SegBinOp comm lam nes shape) = do + (lam', hoisted) <- + Engine.localVtable (\vtable -> vtable { ST.simplifyMemory = True }) $ + Engine.simplifyLambda lam $ replicate (length nes * 2) Nothing + shape' <- Engine.simplify shape + nes' <- mapM Engine.simplify nes + return (SegBinOp comm lam' nes' shape', hoisted) + +-- | Simplify the given 'SegOp'. +simplifySegOp :: (Engine.SimplifiableLore lore, + BodyDec lore ~ (), + Engine.Simplifiable lvl) => + SegOp lvl lore + -> Engine.SimpleM lore (SegOp lvl (Wise lore), Stms (Wise lore)) +simplifySegOp (SegMap lvl space ts kbody) = do + (lvl', space', ts') <- Engine.simplify (lvl, space, ts) + (kbody', body_hoisted) <- simplifyKernelBody space kbody + return (SegMap lvl' space' ts' kbody', + body_hoisted) + +simplifySegOp (SegRed lvl space reds ts kbody) = do + (lvl', space', ts') <- Engine.simplify (lvl, space, ts) + (reds', reds_hoisted) <- Engine.localVtable (<>scope_vtable) $ + unzip <$> mapM simplifySegBinOp reds + (kbody', body_hoisted) <- simplifyKernelBody space kbody + + return (SegRed lvl' space' reds' ts' kbody', + mconcat reds_hoisted <> body_hoisted) + where scope = scopeOfSegSpace space + scope_vtable = ST.fromScope scope + +simplifySegOp (SegScan lvl space scans ts kbody) = do + (lvl', space', ts') <- Engine.simplify (lvl, space, ts) + (scans', scans_hoisted) <- Engine.localVtable (<>scope_vtable) $ + unzip <$> mapM simplifySegBinOp scans + (kbody', body_hoisted) <- simplifyKernelBody space kbody + + return (SegScan lvl' space' scans' ts' kbody', + mconcat scans_hoisted <> body_hoisted) + where scope = scopeOfSegSpace space + scope_vtable = ST.fromScope scope + +simplifySegOp (SegHist lvl space ops ts kbody) = do + (lvl', space', ts') <- Engine.simplify (lvl, space, ts) + + (ops', ops_hoisted) <- fmap unzip $ forM ops $ + \(HistOp w rf arrs nes dims lam) -> do + w' <- Engine.simplify w + rf' <- Engine.simplify rf + arrs' <- Engine.simplify arrs + nes' <- Engine.simplify nes + dims' <- Engine.simplify dims + (lam', op_hoisted) <- + Engine.localVtable (<>scope_vtable) $ + Engine.localVtable (\vtable -> vtable { ST.simplifyMemory = True }) $ + Engine.simplifyLambda lam $ + replicate (length nes * 2) Nothing + return (HistOp w' rf' arrs' nes' dims' lam', + op_hoisted) + + (kbody', body_hoisted) <- simplifyKernelBody space kbody + + return (SegHist lvl' space' ops' ts' kbody', + mconcat ops_hoisted <> body_hoisted) + + where scope = scopeOfSegSpace space + scope_vtable = ST.fromScope scope + +-- | Does this lore contain 'SegOp's in its t'Op's? A lore must be an +-- instance of this class for the simplification rules to work. +class HasSegOp lore where + type SegOpLevel lore + asSegOp :: Op lore -> Maybe (SegOp (SegOpLevel lore) lore) + segOp :: SegOp (SegOpLevel lore) lore -> Op lore + +-- | Simplification rules for simplifying 'SegOp's. +segOpRules :: (HasSegOp lore, BinderOps lore, Bindable lore) => + RuleBook lore +segOpRules = + ruleBook [ RuleOp segOpRuleTopDown ] [ RuleOp segOpRuleBottomUp ] + +segOpRuleTopDown :: (HasSegOp lore, BinderOps lore, Bindable lore) => + TopDownRuleOp lore +segOpRuleTopDown vtable pat dec op + | Just op' <- asSegOp op = + topDownSegOp vtable pat dec op' + | otherwise = + Skip + +segOpRuleBottomUp :: (HasSegOp lore, BinderOps lore) => + BottomUpRuleOp lore +segOpRuleBottomUp vtable pat dec op + | Just op' <- asSegOp op = + bottomUpSegOp vtable pat dec op' + | otherwise = + Skip + +topDownSegOp :: (HasSegOp lore, BinderOps lore, Bindable lore) => + ST.SymbolTable lore + -> Pattern lore + -> StmAux (ExpDec lore) + -> SegOp (SegOpLevel lore) lore + -> Rule lore + +-- If a SegOp produces something invariant to the SegOp, turn it +-- into a replicate. +topDownSegOp vtable (Pattern [] kpes) dec (SegMap lvl space ts (KernelBody _ kstms kres)) = Simplify $ do + (ts', kpes', kres') <- + unzip3 <$> filterM checkForInvarianceResult (zip3 ts kpes kres) + + -- Check if we did anything at all. + when (kres == kres') + cannotSimplify + + kbody <- mkKernelBodyM kstms kres' + addStm $ Let (Pattern [] kpes') dec $ Op $ segOp $ + SegMap lvl space ts' kbody + + where isInvariant Constant{} = True + isInvariant (Var v) = isJust $ ST.lookup v vtable + + checkForInvarianceResult (_, pe, Returns rm se) + | rm == ResultMaySimplify, + isInvariant se = do + letBindNames [patElemName pe] $ + BasicOp $ Replicate (Shape $ segSpaceDims space) se + return False + checkForInvarianceResult _ = + return True + +-- If a SegRed contains two reduction operations that have the same +-- vector shape, merge them together. This saves on communication +-- overhead, but can in principle lead to more local memory usage. +topDownSegOp _ (Pattern [] pes) _ (SegRed lvl space ops ts kbody) + | length ops > 1, + op_groupings <- groupBy sameShape $ zip ops $ chunks (map (length . segBinOpNeutral) ops) $ + zip3 red_pes red_ts red_res, + any ((>1) . length) op_groupings = Simplify $ do + let (ops', aux) = unzip $ mapMaybe combineOps op_groupings + (red_pes', red_ts', red_res') = unzip3 $ concat aux + pes' = red_pes' ++ map_pes + ts' = red_ts' ++ map_ts + kbody' = kbody { kernelBodyResult = red_res' ++ map_res } + letBind (Pattern [] pes') $ Op $ segOp $ SegRed lvl space ops' ts' kbody' + where (red_pes, map_pes) = splitAt (segBinOpResults ops) pes + (red_ts, map_ts) = splitAt (segBinOpResults ops) ts + (red_res, map_res) = splitAt (segBinOpResults ops) $ kernelBodyResult kbody + + sameShape (op1, _) (op2, _) = segBinOpShape op1 == segBinOpShape op2 + + combineOps [] = Nothing + combineOps (x:xs) = Just $ foldl' combine x xs + + combine (op1, op1_aux) (op2, op2_aux) = + let lam1 = segBinOpLambda op1 + lam2 = segBinOpLambda op2 + (op1_xparams, op1_yparams) = + splitAt (length (segBinOpNeutral op1)) $ lambdaParams lam1 + (op2_xparams, op2_yparams) = + splitAt (length (segBinOpNeutral op2)) $ lambdaParams lam2 + lam = Lambda { lambdaParams = op1_xparams ++ op2_xparams ++ + op1_yparams ++ op2_yparams + , lambdaReturnType = lambdaReturnType lam1 ++ lambdaReturnType lam2 + , lambdaBody = + mkBody (bodyStms (lambdaBody lam1) <> bodyStms (lambdaBody lam2)) $ + bodyResult (lambdaBody lam1) <> bodyResult (lambdaBody lam2) + } + in (SegBinOp { segBinOpComm = segBinOpComm op1 <> segBinOpComm op2 + , segBinOpLambda = lam + , segBinOpNeutral = segBinOpNeutral op1 ++ segBinOpNeutral op2 + , segBinOpShape = segBinOpShape op1 -- Same as shape of op2 due to the grouping. + }, + op1_aux ++ op2_aux) +topDownSegOp _ _ _ _ = Skip + +bottomUpSegOp :: (HasSegOp lore, BinderOps lore) => + (ST.SymbolTable lore, UT.UsageTable) + -> Pattern lore + -> StmAux (ExpDec lore) + -> SegOp (SegOpLevel lore) lore + -> Rule lore + +-- Some SegOp results can be moved outside the SegOp, which can +-- simplify further analysis. +bottomUpSegOp (vtable, used) (Pattern [] kpes) dec (SegMap lvl space kts (KernelBody _ kstms kres)) = Simplify $ do + + -- Iterate through the bindings. For each, we check whether it is + -- in kres and can be moved outside. If so, we remove it from kres + -- and kpes and make it a binding outside. + (kpes', kts', kres', kstms') <- localScope (scopeOfSegSpace space) $ + foldM distribute (kpes, kts, kres, mempty) kstms + + when (kpes' == kpes) + cannotSimplify + + kbody <- localScope (scopeOfSegSpace space) $ + mkKernelBodyM kstms' kres' + + addStm $ Let (Pattern [] kpes') dec $ Op $ segOp $ + SegMap lvl space kts' kbody + where + free_in_kstms = foldMap freeIn kstms + + sliceWithGtidsFixed stm + | Let _ _ (BasicOp (Index arr slice)) <- stm, + space_slice <- map (DimFix . Var . fst) $ unSegSpace space, + space_slice `isPrefixOf` slice, + remaining_slice <- drop (length space_slice) slice, + all (isJust . flip ST.lookup vtable) $ namesToList $ + freeIn arr <> freeIn remaining_slice = + Just (remaining_slice, arr) + + | otherwise = + Nothing + + distribute (kpes', kts', kres', kstms') stm + | Let (Pattern [] [pe]) _ _ <- stm, + Just (remaining_slice, arr) <- sliceWithGtidsFixed stm, + Just (kpe, kpes'', kts'', kres'') <- isResult kpes' kts' kres' pe = do + let outer_slice = map (\d -> DimSlice + (constant (0::Int32)) + d + (constant (1::Int32))) $ + segSpaceDims space + index kpe' = letBind (Pattern [] [kpe']) $ BasicOp $ Index arr $ + outer_slice <> remaining_slice + if patElemName kpe `UT.isConsumed` used + then do precopy <- newVName $ baseString (patElemName kpe) <> "_precopy" + index kpe { patElemName = precopy } + letBind (Pattern [] [kpe]) $ BasicOp $ Copy precopy + else index kpe + return (kpes'', kts'', kres'', + if patElemName pe `nameIn` free_in_kstms + then kstms' <> oneStm stm + else kstms') + + distribute (kpes', kts', kres', kstms') stm = + return (kpes', kts', kres', kstms' <> oneStm stm) + + isResult kpes' kts' kres' pe = + case partition matches $ zip3 kpes' kts' kres' of + ([(kpe,_,_)], kpes_and_kres) + | (kpes'', kts'', kres'') <- unzip3 kpes_and_kres -> + Just (kpe, kpes'', kts'', kres'') + _ -> Nothing + where matches (_, _, Returns _ (Var v)) = v == patElemName pe + matches _ = False +bottomUpSegOp _ _ _ _ = Skip + +--- Memory + +kernelBodyReturns :: (Mem lore, HasScope lore m, Monad m) => + KernelBody lore -> [ExpReturns] -> m [ExpReturns] +kernelBodyReturns = zipWithM correct . kernelBodyResult + where correct (WriteReturns _ arr _) _ = varReturns arr + correct _ ret = return ret + +-- | Like 'segOpType', but for memory representations. +segOpReturns :: (Mem lore, Monad m, HasScope lore m) => + SegOp lvl lore -> m [ExpReturns] +segOpReturns k@(SegMap _ _ _ kbody) = + kernelBodyReturns kbody =<< (extReturns <$> opType k) +segOpReturns k@(SegRed _ _ _ _ kbody) = + kernelBodyReturns kbody =<< (extReturns <$> opType k) +segOpReturns k@(SegScan _ _ _ _ kbody) = + kernelBodyReturns kbody =<< (extReturns <$> opType k) +segOpReturns (SegHist _ _ ops _ _) = + concat <$> mapM (mapM varReturns . histDest) ops diff --git a/src/Futhark/IR/Seq.hs b/src/Futhark/IR/Seq.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/IR/Seq.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +-- | A sequential representation. +module Futhark.IR.Seq + ( -- * The Lore definition + Seq + + -- * Simplification + , simplifyProg + + -- * Module re-exports + , module Futhark.IR.Prop + , module Futhark.IR.Traversals + , module Futhark.IR.Pretty + , module Futhark.IR.Syntax + ) +where + +import Futhark.Pass +import Futhark.IR.Syntax +import Futhark.IR.Prop +import Futhark.IR.Traversals +import Futhark.IR.Pretty +import Futhark.Binder +import Futhark.Construct +import qualified Futhark.TypeCheck as TypeCheck +import qualified Futhark.Optimise.Simplify.Engine as Engine +import qualified Futhark.Optimise.Simplify as Simplify +import Futhark.Optimise.Simplify.Rules + +-- | The phantom type for the Seq representation. +data Seq + +instance Decorations Seq where + type Op Seq = () + +instance ASTLore Seq where + expTypesFromPattern = return . expExtTypesFromPattern + +instance TypeCheck.CheckableOp Seq where + checkOp = pure + +instance TypeCheck.Checkable Seq where + +instance Bindable Seq where + mkBody = Body () + mkExpPat ctx val _ = basicPattern ctx val + mkExpDec _ _ = () + mkLetNames = simpleMkLetNames + +instance BinderOps Seq where + +instance PrettyLore Seq where + +instance BinderOps (Engine.Wise Seq) where + +simpleSeq :: Simplify.SimpleOps Seq +simpleSeq = Simplify.bindableSimpleOps (const $ pure ((), mempty)) + +-- | Simplify a sequential program. +simplifyProg :: Prog Seq -> PassM (Prog Seq) +simplifyProg = Simplify.simplifyProg simpleSeq standardRules blockers + where blockers = Engine.noExtraHoistBlockers diff --git a/src/Futhark/IR/SeqMem.hs b/src/Futhark/IR/SeqMem.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/IR/SeqMem.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ConstraintKinds #-} +module Futhark.IR.SeqMem + ( SeqMem + + -- * Simplification + , simplifyProg + , simpleSeqMem + + -- * Module re-exports + , module Futhark.IR.Mem + , module Futhark.IR.Kernels.Kernel + ) + where + +import Futhark.Analysis.PrimExp.Convert +import Futhark.Pass +import Futhark.IR.Syntax +import Futhark.IR.Prop +import Futhark.IR.Traversals +import Futhark.IR.Pretty +import Futhark.IR.Kernels.Kernel +import qualified Futhark.TypeCheck as TC +import Futhark.IR.Mem +import Futhark.IR.Mem.Simplify +import Futhark.Pass.ExplicitAllocations (BinderOps(..), mkLetNamesB', mkLetNamesB'') +import qualified Futhark.Optimise.Simplify.Engine as Engine + +data SeqMem + +instance Decorations SeqMem where + type LetDec SeqMem = LetDecMem + type FParamInfo SeqMem = FParamMem + type LParamInfo SeqMem = LParamMem + type RetType SeqMem = RetTypeMem + type BranchType SeqMem = BranchTypeMem + type Op SeqMem = MemOp () + +instance ASTLore SeqMem where + expTypesFromPattern = return . map snd . snd . bodyReturnsFromPattern + +instance OpReturns SeqMem where + opReturns (Alloc _ space) = return [MemMem space] + opReturns (Inner ()) = pure [] + +instance PrettyLore SeqMem where + +instance TC.CheckableOp SeqMem where + checkOp (Alloc size _) = + TC.require [Prim int64] size + checkOp (Inner ()) = + pure () + +instance TC.Checkable SeqMem where + checkFParamLore = checkMemInfo + checkLParamLore = checkMemInfo + checkLetBoundLore = checkMemInfo + checkRetType = mapM_ (TC.checkExtType . declExtTypeOf) + primFParam name t = return $ Param name (MemPrim t) + matchPattern = matchPatternToExp + matchReturnType = matchFunctionReturnType + matchBranchType = matchBranchReturnType + +instance BinderOps SeqMem where + mkExpDecB _ _ = return () + mkBodyB stms res = return $ Body () stms res + mkLetNamesB = mkLetNamesB' () + +instance BinderOps (Engine.Wise SeqMem) where + mkExpDecB pat e = return $ Engine.mkWiseExpDec pat () e + mkBodyB stms res = return $ Engine.mkWiseBody () stms res + mkLetNamesB = mkLetNamesB'' + +simplifyProg :: Prog SeqMem -> PassM (Prog SeqMem) +simplifyProg = + simplifyProgGeneric $ const $ return ((), mempty) + +simpleSeqMem :: Engine.SimpleOps SeqMem +simpleSeqMem = + simpleGeneric $ const $ return ((), mempty) diff --git a/src/Futhark/IR/Syntax.hs b/src/Futhark/IR/Syntax.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/IR/Syntax.hs @@ -0,0 +1,534 @@ +{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances, StandaloneDeriving #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE Strict #-} +{-# LANGUAGE Trustworthy #-} +-- | = Definition of the Futhark core language IR +-- +-- For actually /constructing/ ASTs, see "Futhark.Construct". +-- +-- == Types and values +-- +-- The core language type system is much more restricted than the core +-- language. This is a theme that repeats often. The only types that +-- are supported in the core language are various primitive types +-- t'PrimType' which can be combined in arrays (ignore v'Mem' for +-- now). Types are represented as t'TypeBase', which is parameterised +-- by the shape of the array and whether we keep uniqueness +-- information. The t'Type' alias, which is the most commonly used, +-- uses t'Shape' and t'NoUniqueness'. +-- +-- This means that the records, tuples, and sum types of the source +-- language are represented merely as collections of primitives and +-- arrays. This is implemented in "Futhark.Internalise", but the +-- specifics are not important for writing passes on the core +-- language. What /is/ important is that many constructs that +-- conceptually return tuples instead return /multiple values/. This +-- is not merely syntactic sugar for a tuple: each of those values are +-- eventually bound to distinct variables. The prettyprinter for the +-- IR will typically print such collections of values or types in +-- curly braces. +-- +-- The system of primitive types is interesting in itself. See +-- "Futhark.IR.Primitive". +-- +-- == Overall AST design +-- +-- Internally, the Futhark compiler core intermediate representation +-- resembles a traditional compiler for an imperative language more +-- than it resembles, say, a Haskell or ML compiler. All functions +-- are monomorphic (except for sizes), first-order, and defined at the +-- top level. Notably, the IR does /not/ use continuation-passing +-- style (CPS) at any time. Instead it uses Administrative Normal +-- Form (ANF), where all subexpressions t'SubExp' are either +-- constants 'PrimValue' or variables 'VName'. Variables are +-- represented as a human-readable t'Name' (which doesn't matter to +-- the compiler) as well as a numeric /tag/, which is what the +-- compiler actually looks at. All variable names when prettyprinted +-- are of the form @foo_123@. Function names are just t'Name's, +-- though. +-- +-- The body of a function ('FunDef') is a t'Body', which consists of +-- a sequence of statements ('Stms') and a t'Result'. Execution of a +-- t'Body' consists of executing all of the statements, then returning +-- the values of the variables indicated by the result. +-- +-- A statement ('Stm') consists of a t'Pattern' alongside an +-- expression 'ExpT'. A pattern contains a "context" part and a +-- "value" part. The context is used for things like the size of +-- arrays in the value part whose size is existential. +-- +-- For example, the source language expression @let z = x + y - 1 in +-- z@ would in the core language be represented (in prettyprinted +-- form) as something like: +-- +-- @ +-- let {a_12} = x_10 + y_11 +-- let {b_13} = a_12 - 1 +-- in {b_13} +-- @ +-- +-- == Lores +-- +-- Most AST types ('Stm', 'ExpT', t'Prog', etc) are parameterised by a +-- type parameter with the somewhat silly name @lore@. The lore +-- specifies how to fill out various polymorphic parts of the AST. +-- For example, 'ExpT' has a constructor v'Op' whose payload depends +-- on @lore@, via the use of a type family called t'Op' (a kind of +-- type-level function) which is applied to the @lore@. The SOACS +-- representation ("Futhark.IR.SOACS") thus uses a lore +-- called @SOACS@, and defines that @Op SOACS@ is a SOAC, while the +-- Kernels representation ("Futhark.IR.Kernels") defines +-- @Op Kernels@ as some kind of kernel construct. Similarly, various +-- other decorations (e.g. what information we store in a t'PatElemT') +-- are also type families. +-- +-- The full list of possible decorations is defined as part of the +-- type class 'Decorations' (although other type families are also +-- used elsewhere in the compiler on an ad hoc basis). +-- +-- Essentially, the @lore@ type parameter functions as a kind of +-- proxy, saving us from having to parameterise the AST type with all +-- the different forms of decorations that we desire (it would easily +-- become a type with a dozen type parameters). +-- +-- Defining a new representation (or /lore/) thus requires you to +-- define an empty datatype and implement a handful of type class +-- instances for it. See the source of "Futhark.IR.Seq" +-- for what is likely the simplest example. +module Futhark.IR.Syntax + ( + module Language.Futhark.Core + , module Futhark.IR.Decorations + , module Futhark.IR.Syntax.Core + + -- * Types + , Uniqueness(..) + , NoUniqueness(..) + , Rank(..) + , ArrayShape(..) + , Space (..) + , TypeBase(..) + , Diet(..) + + -- * Attributes + , Attr(..) + , Attrs(..) + , oneAttr + , inAttrs + + -- * Abstract syntax tree + , Ident (..) + , SubExp(..) + , PatElem + , PatElemT (..) + , PatternT (..) + , Pattern + , StmAux(..) + , Stm(..) + , Stms + , Result + , BodyT(..) + , Body + , BasicOp (..) + , UnOp (..) + , BinOp (..) + , CmpOp (..) + , ConvOp (..) + , DimChange (..) + , ShapeChange + , ExpT(..) + , Exp + , LoopForm (..) + , IfDec (..) + , IfSort (..) + , Safety (..) + , LambdaT(..) + , Lambda + + -- * Definitions + , Param (..) + , FParam + , LParam + , FunDef (..) + , EntryPoint + , EntryPointType(..) + , Prog(..) + + -- * Utils + , oneStm + , stmsFromList + , stmsToList + , stmsHead + ) + where + +import qualified Data.Set as S +import Data.Foldable +import qualified Data.Sequence as Seq +import Data.String +import Data.Traversable (fmapDefault, foldMapDefault) + +import Language.Futhark.Core +import Futhark.IR.Decorations +import Futhark.IR.Syntax.Core + +-- | A single attribute. +newtype Attr = AttrAtom Name + deriving (Ord, Show, Eq) + +instance IsString Attr where + fromString = AttrAtom . fromString + +-- | Every statement is associated with a set of attributes, which can +-- have various effects throughout the compiler. +newtype Attrs = Attrs { unAttrs :: S.Set Attr } + deriving (Ord, Show, Eq, Monoid, Semigroup) + +-- | Construct 'Attrs' from a single 'Attr'. +oneAttr :: Attr -> Attrs +oneAttr = Attrs . S.singleton + +-- | Is the given attribute to be found in the attribute set? +inAttrs :: Attr -> Attrs -> Bool +inAttrs attr (Attrs attrs) = attr `S.member` attrs + +-- | A type alias for namespace control. +type PatElem lore = PatElemT (LetDec lore) + +-- | A pattern is conceptually just a list of names and their types. +data PatternT dec = + Pattern { patternContextElements :: [PatElemT dec] + -- ^ existential context (sizes and memory blocks) + , patternValueElements :: [PatElemT dec] + -- ^ "real" values + } + deriving (Ord, Show, Eq) + +instance Semigroup (PatternT dec) where + Pattern cs1 vs1 <> Pattern cs2 vs2 = Pattern (cs1++cs2) (vs1++vs2) + +instance Monoid (PatternT dec) where + mempty = Pattern [] [] + +instance Functor PatternT where + fmap = fmapDefault + +instance Foldable PatternT where + foldMap = foldMapDefault + +instance Traversable PatternT where + traverse f (Pattern ctx vals) = + Pattern <$> traverse (traverse f) ctx <*> traverse (traverse f) vals + +-- | A type alias for namespace control. +type Pattern lore = PatternT (LetDec lore) + +-- | Auxilliary Information associated with a statement. +data StmAux dec = StmAux { stmAuxCerts :: !Certificates + , stmAuxAttrs :: Attrs + , stmAuxDec :: dec + } + deriving (Ord, Show, Eq) + +instance Semigroup dec => Semigroup (StmAux dec) where + StmAux cs1 attrs1 dec1 <> StmAux cs2 attrs2 dec2 = + StmAux (cs1<>cs2) (attrs1<>attrs2) (dec1<>dec2) + +-- | A local variable binding. +data Stm lore = Let { stmPattern :: Pattern lore + -- ^ Pattern. + , stmAux :: StmAux (ExpDec lore) + -- ^ Auxiliary information statement. + , stmExp :: Exp lore + -- ^ Expression. + } + +deriving instance Decorations lore => Ord (Stm lore) +deriving instance Decorations lore => Show (Stm lore) +deriving instance Decorations lore => Eq (Stm lore) + +-- | A sequence of statements. +type Stms lore = Seq.Seq (Stm lore) + +-- | A single statement. +oneStm :: Stm lore -> Stms lore +oneStm = Seq.singleton + +-- | Convert a statement list to a statement sequence. +stmsFromList :: [Stm lore] -> Stms lore +stmsFromList = Seq.fromList + +-- | Convert a statement sequence to a statement list. +stmsToList :: Stms lore -> [Stm lore] +stmsToList = toList + +-- | The first statement in the sequence, if any. +stmsHead :: Stms lore -> Maybe (Stm lore, Stms lore) +stmsHead stms = case Seq.viewl stms of stm Seq.:< stms' -> Just (stm, stms') + Seq.EmptyL -> Nothing + +-- | The result of a body is a sequence of subexpressions. +type Result = [SubExp] + +-- | A body consists of a number of bindings, terminating in a result +-- (essentially a tuple literal). +data BodyT lore = Body { bodyDec :: BodyDec lore + , bodyStms :: Stms lore + , bodyResult :: Result + } + +deriving instance Decorations lore => Ord (BodyT lore) +deriving instance Decorations lore => Show (BodyT lore) +deriving instance Decorations lore => Eq (BodyT lore) + +-- | Type alias for namespace reasons. +type Body = BodyT + +-- | The new dimension in a 'Reshape'-like operation. This allows us to +-- disambiguate "real" reshapes, that change the actual shape of the +-- array, from type coercions that are just present to make the types +-- work out. The two constructors are considered equal for purposes of 'Eq'. +data DimChange d = DimCoercion d + -- ^ The new dimension is guaranteed to be numerically + -- equal to the old one. + | DimNew d + -- ^ The new dimension is not necessarily numerically + -- equal to the old one. + deriving (Ord, Show) + +instance Eq d => Eq (DimChange d) where + DimCoercion x == DimNew y = x == y + DimCoercion x == DimCoercion y = x == y + DimNew x == DimCoercion y = x == y + DimNew x == DimNew y = x == y + +instance Functor DimChange where + fmap f (DimCoercion d) = DimCoercion $ f d + fmap f (DimNew d) = DimNew $ f d + +instance Foldable DimChange where + foldMap f (DimCoercion d) = f d + foldMap f (DimNew d) = f d + +instance Traversable DimChange where + traverse f (DimCoercion d) = DimCoercion <$> f d + traverse f (DimNew d) = DimNew <$> f d + +-- | A list of 'DimChange's, indicating the new dimensions of an array. +type ShapeChange d = [DimChange d] + +-- | A primitive operation that returns something of known size and +-- does not itself contain any bindings. +data BasicOp + = SubExp SubExp + -- ^ A variable or constant. + + | Opaque SubExp + -- ^ Semantically and operationally just identity, but is + -- invisible/impenetrable to optimisations (hopefully). This is + -- just a hack to avoid optimisation (so, to work around compiler + -- limitations). + + | ArrayLit [SubExp] Type + -- ^ Array literals, e.g., @[ [1+x, 3], [2, 1+4] ]@. + -- Second arg is the element type of the rows of the array. + -- Scalar operations + + | UnOp UnOp SubExp + -- ^ Unary operation. + + | BinOp BinOp SubExp SubExp + -- ^ Binary operation. + + | CmpOp CmpOp SubExp SubExp + -- ^ Comparison - result type is always boolean. + + | ConvOp ConvOp SubExp + -- ^ Conversion "casting". + + | Assert SubExp (ErrorMsg SubExp) (SrcLoc, [SrcLoc]) + -- ^ Turn a boolean into a certificate, halting the program with the + -- given error message if the boolean is false. + + -- Primitive array operations + + | Index VName (Slice SubExp) + -- ^ The certificates for bounds-checking are part of the 'Stm'. + + | Update VName (Slice SubExp) SubExp + -- ^ An in-place update of the given array at the given position. + -- Consumes the array. + + | Concat Int VName [VName] SubExp + -- ^ @concat@0([1],[2, 3, 4]) = [1, 2, 3, 4]@. + + | Copy VName + -- ^ Copy the given array. The result will not alias anything. + + | Manifest [Int] VName + -- ^ Manifest an array with dimensions represented in the given + -- order. The result will not alias anything. + + -- Array construction. + | Iota SubExp SubExp SubExp IntType + -- ^ @iota(n, x, s) = [x,x+s,..,x+(n-1)*s]@. + -- + -- The t'IntType' indicates the type of the array returned and the + -- offset/stride arguments, but not the length argument. + + | Replicate Shape SubExp + -- ^ @replicate([3][2],1) = [[1,1], [1,1], [1,1]]@ + + | Repeat [Shape] Shape VName + -- ^ Repeat each dimension of the input array some number of times, + -- given by the corresponding shape. For an array of rank @k@, the + -- list must contain @k@ shapes. A shape may be empty (in which + -- case the dimension is not repeated, but it is still present). + -- The last shape indicates the amount of extra innermost + -- dimensions. All other extra dimensions are added *before* the original dimension. + + | Scratch PrimType [SubExp] + -- ^ Create array of given type and shape, with undefined elements. + + -- Array index space transformation. + | Reshape (ShapeChange SubExp) VName + -- ^ 1st arg is the new shape, 2nd arg is the input array *) + + | Rearrange [Int] VName + -- ^ Permute the dimensions of the input array. The list + -- of integers is a list of dimensions (0-indexed), which + -- must be a permutation of @[0,n-1]@, where @n@ is the + -- number of dimensions in the input array. + + | Rotate [SubExp] VName + -- ^ Rotate the dimensions of the input array. The list of + -- subexpressions specify how much each dimension is rotated. The + -- length of this list must be equal to the rank of the array. + deriving (Eq, Ord, Show) + +-- | The root Futhark expression type. The v'Op' constructor contains +-- a lore-specific operation. Do-loops, branches and function calls +-- are special. Everything else is a simple t'BasicOp'. +data ExpT lore + = BasicOp BasicOp + -- ^ A simple (non-recursive) operation. + + | Apply Name [(SubExp, Diet)] [RetType lore] (Safety, SrcLoc, [SrcLoc]) + + | If SubExp (BodyT lore) (BodyT lore) (IfDec (BranchType lore)) + + | DoLoop [(FParam lore, SubExp)] [(FParam lore, SubExp)] (LoopForm lore) (BodyT lore) + -- ^ @loop {a} = {v} (for i < n|while b) do b@. The merge + -- parameters are divided into context and value part. + + | Op (Op lore) + +deriving instance Decorations lore => Eq (ExpT lore) +deriving instance Decorations lore => Show (ExpT lore) +deriving instance Decorations lore => Ord (ExpT lore) + +-- | Whether something is safe or unsafe (mostly function calls, and +-- in the context of whether operations are dynamically checked). +-- When we inline an 'Unsafe' function, we remove all safety checks in +-- its body. The 'Ord' instance picks 'Unsafe' as being less than +-- 'Safe'. +data Safety = Unsafe | Safe deriving (Eq, Ord, Show) + +-- | For-loop or while-loop? +data LoopForm lore = ForLoop VName IntType SubExp [(LParam lore,VName)] + | WhileLoop VName + +deriving instance Decorations lore => Eq (LoopForm lore) +deriving instance Decorations lore => Show (LoopForm lore) +deriving instance Decorations lore => Ord (LoopForm lore) + +-- | Data associated with a branch. +data IfDec rt = IfDec { ifReturns :: [rt] + , ifSort :: IfSort + } + deriving (Eq, Show, Ord) + +-- | What kind of branch is this? This has no semantic meaning, but +-- provides hints to simplifications. +data IfSort = IfNormal + -- ^ An ordinary branch. + | IfFallback + -- ^ A branch where the "true" case is what we are + -- actually interested in, and the "false" case is only + -- present as a fallback for when the true case cannot + -- be safely evaluated. the compiler is permitted to + -- optimise away the branch if the true case contains + -- only safe statements. + | IfEquiv + -- ^ Both of these branches are semantically equivalent, + -- and it is fine to eliminate one if it turns out to + -- have problems (e.g. contain things we cannot generate + -- code for). + deriving (Eq, Show, Ord) + +-- | A type alias for namespace control. +type Exp = ExpT + +-- | Anonymous function for use in a SOAC. +data LambdaT lore = Lambda { lambdaParams :: [LParam lore] + , lambdaBody :: BodyT lore + , lambdaReturnType :: [Type] + } + +deriving instance Decorations lore => Eq (LambdaT lore) +deriving instance Decorations lore => Show (LambdaT lore) +deriving instance Decorations lore => Ord (LambdaT lore) + +-- | Type alias for namespacing reasons. +type Lambda = LambdaT + +-- | A function and loop parameter. +type FParam lore = Param (FParamInfo lore) + +-- | A lambda parameter. +type LParam lore = Param (LParamInfo lore) + +-- | Function Declarations +data FunDef lore = FunDef { funDefEntryPoint :: Maybe EntryPoint + -- ^ Contains a value if this function is + -- an entry point. + , funDefName :: Name + , funDefRetType :: [RetType lore] + , funDefParams :: [FParam lore] + , funDefBody :: BodyT lore + } + +deriving instance Decorations lore => Eq (FunDef lore) +deriving instance Decorations lore => Show (FunDef lore) +deriving instance Decorations lore => Ord (FunDef lore) + +-- | Information about the parameters and return value of an entry +-- point. The first element is for parameters, the second for return +-- value. +type EntryPoint = ([EntryPointType], [EntryPointType]) + +-- | Every entry point argument and return value has an annotation +-- indicating how it maps to the original source program type. +data EntryPointType = TypeUnsigned + -- ^ Is an unsigned integer or array of unsigned + -- integers. + | TypeOpaque String Int + -- ^ A black box type comprising this many core + -- values. The string is a human-readable + -- description with no other semantics. + | TypeDirect + -- ^ Maps directly. + deriving (Eq, Show, Ord) + +-- | An entire Futhark program. +data Prog lore = Prog + { progConsts :: Stms lore + -- ^ Top-level constants that are computed at program startup, and + -- which are in scope inside all functions. + + , progFuns :: [FunDef lore] + -- ^ The functions comprising the program. All funtions are also + -- available in scope in the definitions of the constants, so be + -- careful not to introduce circular dependencies (not currently + -- checked). + } deriving (Eq, Ord, Show) diff --git a/src/Futhark/IR/Syntax/Core.hs b/src/Futhark/IR/Syntax/Core.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/IR/Syntax/Core.hs @@ -0,0 +1,363 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE Strict #-} +-- | The most primitive ("core") aspects of the AST. Split out of +-- "Futhark.IR.Syntax" in order for +-- "Futhark.IR.Decorations" to use these definitions. This +-- module is re-exported from "Futhark.IR.Syntax" and +-- there should be no reason to include it explicitly. +module Futhark.IR.Syntax.Core + ( + module Language.Futhark.Core + , module Futhark.IR.Primitive + + -- * Types + , Uniqueness(..) + , NoUniqueness(..) + , ShapeBase(..) + , Shape + , Ext(..) + , ExtSize + , ExtShape + , Rank(..) + , ArrayShape(..) + , Space (..) + , SpaceId + , TypeBase(..) + , Type + , ExtType + , DeclType + , DeclExtType + , Diet(..) + , ErrorMsg (..) + , ErrorMsgPart (..) + , errorMsgArgTypes + + -- * Values + , PrimValue(..) + + -- * Abstract syntax tree + , Ident (..) + , Certificates(..) + , SubExp(..) + , Param (..) + , DimIndex (..) + , Slice + , dimFix + , sliceIndices + , sliceDims + , unitSlice + , fixSlice + , PatElemT (..) + ) where + +import Control.Monad.State +import Data.Maybe +import Data.String +import qualified Data.Map.Strict as M +import Data.Traversable (fmapDefault, foldMapDefault) + +import Language.Futhark.Core +import Futhark.IR.Primitive + +-- | The size of an array type as a list of its dimension sizes, with +-- the type of sizes being parametric. +newtype ShapeBase d = Shape { shapeDims :: [d] } + deriving (Eq, Ord, Show) + +-- | The size of an array as a list of subexpressions. If a variable, +-- that variable must be in scope where this array is used. +type Shape = ShapeBase SubExp + +-- | Something that may be existential. +data Ext a = Ext Int + | Free a + deriving (Eq, Ord, Show) + +-- | The size of this dimension. +type ExtSize = Ext SubExp + +-- | Like t'Shape' but some of its elements may be bound in a local +-- environment instead. These are denoted with integral indices. +type ExtShape = ShapeBase ExtSize + +-- | The size of an array type as merely the number of dimensions, +-- with no further information. +newtype Rank = Rank Int + deriving (Show, Eq, Ord) + +-- | A class encompassing types containing array shape information. +class (Monoid a, Eq a, Ord a) => ArrayShape a where + -- | Return the rank of an array with the given size. + shapeRank :: a -> Int + -- | @stripDims n shape@ strips the outer @n@ dimensions from + -- @shape@. + stripDims :: Int -> a -> a + -- | Check whether one shape if a subset of another shape. + subShapeOf :: a -> a -> Bool + +instance Semigroup (ShapeBase d) where + Shape l1 <> Shape l2 = Shape $ l1 `mappend` l2 + +instance Monoid (ShapeBase d) where + mempty = Shape mempty + +instance Functor ShapeBase where + fmap f = Shape . map f . shapeDims + +instance ArrayShape (ShapeBase SubExp) where + shapeRank (Shape l) = length l + stripDims n (Shape dims) = Shape $ drop n dims + subShapeOf = (==) + +instance ArrayShape (ShapeBase ExtSize) where + shapeRank (Shape l) = length l + stripDims n (Shape dims) = Shape $ drop n dims + subShapeOf (Shape ds1) (Shape ds2) = + -- Must agree on Free dimensions, and ds1 may not be existential + -- where ds2 is Free. Existentials must also be congruent. + length ds1 == length ds2 && + evalState (and <$> zipWithM subDimOf ds1 ds2) M.empty + where subDimOf (Free se1) (Free se2) = return $ se1 == se2 + subDimOf (Ext _) (Free _) = return False + subDimOf (Free _) (Ext _) = return True + subDimOf (Ext x) (Ext y) = do + extmap <- get + case M.lookup y extmap of + Just ywas | ywas == x -> return True + | otherwise -> return False + Nothing -> do put $ M.insert y x extmap + return True + +instance Semigroup Rank where + Rank x <> Rank y = Rank $ x + y + +instance Monoid Rank where + mempty = Rank 0 + +instance ArrayShape Rank where + shapeRank (Rank x) = x + stripDims n (Rank x) = Rank $ x - n + subShapeOf = (==) + +-- | The memory space of a block. If 'DefaultSpace', this is the "default" +-- space, whatever that is. The exact meaning of the 'SpaceId' +-- depends on the backend used. In GPU kernels, for example, this is +-- used to distinguish between constant, global and shared memory +-- spaces. In GPU-enabled host code, it is used to distinguish +-- between host memory ('DefaultSpace') and GPU space. +data Space = DefaultSpace + | Space SpaceId + | ScalarSpace [SubExp] PrimType + -- ^ A special kind of memory that is a statically sized + -- array of some primitive type. Used for private memory + -- on GPUs. + deriving (Show, Eq, Ord) + +-- | A string representing a specific non-default memory space. +type SpaceId = String + +-- | A fancier name for @()@ - encodes no uniqueness information. +data NoUniqueness = NoUniqueness + deriving (Eq, Ord, Show) + +-- | An Futhark type is either an array or an element type. When +-- comparing types for equality with '==', shapes must match. +data TypeBase shape u = Prim PrimType + | Array PrimType shape u + | Mem Space + deriving (Show, Eq, Ord) + +-- | A type with shape information, used for describing the type of +-- variables. +type Type = TypeBase Shape NoUniqueness + +-- | A type with existentially quantified shapes - used as part of +-- function (and function-like) return types. Generally only makes +-- sense when used in a list. +type ExtType = TypeBase ExtShape NoUniqueness + +-- | A type with shape and uniqueness information, used declaring +-- return- and parameters types. +type DeclType = TypeBase Shape Uniqueness + +-- | An 'ExtType' with uniqueness information, used for function +-- return types. +type DeclExtType = TypeBase ExtShape Uniqueness + +-- | Information about which parts of a value/type are consumed. For +-- example, we might say that a function taking three arguments of +-- types @([int], *[int], [int])@ has diet @[Observe, Consume, +-- Observe]@. +data Diet = Consume -- ^ Consumes this value. + | Observe -- ^ Only observes value in this position, does + -- not consume. A result may alias this. + | ObservePrim -- ^ As 'Observe', but the result will not + -- alias, because the parameter does not carry + -- aliases. + deriving (Eq, Ord, Show) + +-- | An identifier consists of its name and the type of the value +-- bound to the identifier. +data Ident = Ident { identName :: VName + , identType :: Type + } + deriving (Show) + +instance Eq Ident where + x == y = identName x == identName y + +instance Ord Ident where + x `compare` y = identName x `compare` identName y + +-- | A list of names used for certificates in some expressions. +newtype Certificates = Certificates { unCertificates :: [VName] } + deriving (Eq, Ord, Show) + +instance Semigroup Certificates where + Certificates x <> Certificates y = Certificates (x <> y) + +instance Monoid Certificates where + mempty = Certificates mempty + +-- | A subexpression is either a scalar constant or a variable. One +-- important property is that evaluation of a subexpression is +-- guaranteed to complete in constant time. +data SubExp = Constant PrimValue + | Var VName + deriving (Show, Eq, Ord) + +-- | A function or lambda parameter. +data Param dec = Param + { paramName :: VName + -- ^ Name of the parameter. + , paramDec :: dec + -- ^ Function parameter decoration. + } deriving (Ord, Show, Eq) + +instance Foldable Param where + foldMap = foldMapDefault + +instance Functor Param where + fmap = fmapDefault + +instance Traversable Param where + traverse f (Param name dec) = Param name <$> f dec + +-- | How to index a single dimension of an array. +data DimIndex d = DimFix + d -- ^ Fix index in this dimension. + | DimSlice d d d + -- ^ @DimSlice start_offset num_elems stride@. + deriving (Eq, Ord, Show) + +instance Functor DimIndex where + fmap f (DimFix i) = DimFix $ f i + fmap f (DimSlice i j s) = DimSlice (f i) (f j) (f s) + +instance Foldable DimIndex where + foldMap f (DimFix d) = f d + foldMap f (DimSlice i j s) = f i <> f j <> f s + +instance Traversable DimIndex where + traverse f (DimFix d) = DimFix <$> f d + traverse f (DimSlice i j s) = DimSlice <$> f i <*> f j <*> f s + +-- | A list of 'DimFix's, indicating how an array should be sliced. +-- Whenever a function accepts a 'Slice', that slice should be total, +-- i.e, cover all dimensions of the array. Deviators should be +-- indicated by taking a list of 'DimIndex'es instead. +type Slice d = [DimIndex d] + +-- | If the argument is a 'DimFix', return its component. +dimFix :: DimIndex d -> Maybe d +dimFix (DimFix d) = Just d +dimFix _ = Nothing + +-- | If the slice is all 'DimFix's, return the components. +sliceIndices :: Slice d -> Maybe [d] +sliceIndices = mapM dimFix + +-- | The dimensions of the array produced by this slice. +sliceDims :: Slice d -> [d] +sliceDims = mapMaybe dimSlice + where dimSlice (DimSlice _ d _) = Just d + dimSlice DimFix{} = Nothing + +-- | A slice with a stride of one. +unitSlice :: Num d => d -> d -> DimIndex d +unitSlice offset n = DimSlice offset n 1 + +-- | Fix the 'DimSlice's of a slice. The number of indexes must equal +-- the length of 'sliceDims' for the slice. +fixSlice :: Num d => Slice d -> [d] -> [d] +fixSlice (DimFix j:mis') is' = + j : fixSlice mis' is' +fixSlice (DimSlice orig_k _ orig_s:mis') (i:is') = + (orig_k+i*orig_s) : fixSlice mis' is' +fixSlice _ _ = [] + +-- | An element of a pattern - consisting of a name and an addditional +-- parametric decoration. This decoration is what is expected to +-- contain the type of the resulting variable. +data PatElemT dec = PatElem { patElemName :: VName + -- ^ The name being bound. + , patElemDec :: dec + -- ^ Pattern element decoration. + } + deriving (Ord, Show, Eq) + +instance Functor PatElemT where + fmap = fmapDefault + +instance Foldable PatElemT where + foldMap = foldMapDefault + +instance Traversable PatElemT where + traverse f (PatElem name dec) = + PatElem name <$> f dec + +-- | An error message is a list of error parts, which are concatenated +-- to form the final message. +newtype ErrorMsg a = ErrorMsg [ErrorMsgPart a] + deriving (Eq, Ord, Show) + +instance IsString (ErrorMsg a) where + fromString = ErrorMsg . pure . fromString + +-- | A part of an error message. +data ErrorMsgPart a = ErrorString String -- ^ A literal string. + | ErrorInt32 a -- ^ A run-time integer value. + deriving (Eq, Ord, Show) + +instance IsString (ErrorMsgPart a) where + fromString = ErrorString + +instance Functor ErrorMsg where + fmap f (ErrorMsg parts) = ErrorMsg $ map (fmap f) parts + +instance Foldable ErrorMsg where + foldMap f (ErrorMsg parts) = foldMap (foldMap f) parts + +instance Traversable ErrorMsg where + traverse f (ErrorMsg parts) = ErrorMsg <$> traverse (traverse f) parts + +instance Functor ErrorMsgPart where + fmap _ (ErrorString s) = ErrorString s + fmap f (ErrorInt32 a) = ErrorInt32 $ f a + +instance Foldable ErrorMsgPart where + foldMap _ ErrorString{} = mempty + foldMap f (ErrorInt32 a) = f a + +instance Traversable ErrorMsgPart where + traverse _ (ErrorString s) = pure $ ErrorString s + traverse f (ErrorInt32 a) = ErrorInt32 <$> f a + +-- | How many non-constant parts does the error message have, and what +-- is their type? +errorMsgArgTypes :: ErrorMsg a -> [PrimType] +errorMsgArgTypes (ErrorMsg parts) = mapMaybe onPart parts + where onPart ErrorString{} = Nothing + onPart ErrorInt32{} = Just $ IntType Int32 diff --git a/src/Futhark/IR/Traversals.hs b/src/Futhark/IR/Traversals.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/IR/Traversals.hs @@ -0,0 +1,279 @@ +{-# LANGUAGE Safe #-} +-- | +-- +-- Functions for generic traversals across Futhark syntax trees. The +-- motivation for this module came from dissatisfaction with rewriting +-- the same trivial tree recursions for every module. A possible +-- alternative would be to use normal \"Scrap your +-- boilerplate\"-techniques, but these are rejected for two reasons: +-- +-- * They are too slow. +-- +-- * More importantly, they do not tell you whether you have missed +-- some cases. +-- +-- Instead, this module defines various traversals of the Futhark syntax +-- tree. The implementation is rather tedious, but the interface is +-- easy to use. +-- +-- A traversal of the Futhark syntax tree is expressed as a record of +-- functions expressing the operations to be performed on the various +-- types of nodes. +-- +-- The "Futhark.Transform.Rename" module is a simple example of how to +-- use this facility. +module Futhark.IR.Traversals + ( + -- * Mapping + Mapper(..) + , identityMapper + , mapExpM + , mapExp + , mapOnType + + -- * Walking + , Walker(..) + , identityWalker + , walkExpM + ) + where + +import Control.Monad +import Control.Monad.Identity +import qualified Data.Traversable +import Data.Foldable (traverse_) + +import Futhark.IR.Syntax +import Futhark.IR.Prop.Scope + +-- | Express a monad mapping operation on a syntax node. Each element +-- of this structure expresses the operation to be performed on a +-- given child. +data Mapper flore tlore m = Mapper { + mapOnSubExp :: SubExp -> m SubExp + , mapOnBody :: Scope tlore -> Body flore -> m (Body tlore) + -- ^ Most bodies are enclosed in a scope, which is passed along + -- for convenience. + , mapOnVName :: VName -> m VName + , mapOnRetType :: RetType flore -> m (RetType tlore) + , mapOnBranchType :: BranchType flore -> m (BranchType tlore) + , mapOnFParam :: FParam flore -> m (FParam tlore) + , mapOnLParam :: LParam flore -> m (LParam tlore) + , mapOnOp :: Op flore -> m (Op tlore) + } + +-- | A mapper that simply returns the tree verbatim. +identityMapper :: Monad m => Mapper lore lore m +identityMapper = Mapper { + mapOnSubExp = return + , mapOnBody = const return + , mapOnVName = return + , mapOnRetType = return + , mapOnBranchType = return + , mapOnFParam = return + , mapOnLParam = return + , mapOnOp = return + } + +-- | Map a monadic action across the immediate children of an +-- expression. Importantly, the mapping does not descend recursively +-- into subexpressions. The mapping is done left-to-right. +mapExpM :: (Applicative m, Monad m) => + Mapper flore tlore m -> Exp flore -> m (Exp tlore) +mapExpM tv (BasicOp (SubExp se)) = + BasicOp <$> (SubExp <$> mapOnSubExp tv se) +mapExpM tv (BasicOp (ArrayLit els rowt)) = + BasicOp <$> (ArrayLit <$> mapM (mapOnSubExp tv) els <*> + mapOnType (mapOnSubExp tv) rowt) +mapExpM tv (BasicOp (BinOp bop x y)) = + BasicOp <$> (BinOp bop <$> mapOnSubExp tv x <*> mapOnSubExp tv y) +mapExpM tv (BasicOp (CmpOp op x y)) = + BasicOp <$> (CmpOp op <$> mapOnSubExp tv x <*> mapOnSubExp tv y) +mapExpM tv (BasicOp (ConvOp conv x)) = + BasicOp <$> (ConvOp conv <$> mapOnSubExp tv x) +mapExpM tv (BasicOp (UnOp op x)) = + BasicOp <$> (UnOp op <$> mapOnSubExp tv x) +mapExpM tv (If c texp fexp (IfDec ts s)) = + If <$> mapOnSubExp tv c <*> mapOnBody tv mempty texp <*> mapOnBody tv mempty fexp <*> + (IfDec <$> mapM (mapOnBranchType tv) ts <*> pure s) +mapExpM tv (Apply fname args ret loc) = do + args' <- forM args $ \(arg, d) -> + (,) <$> mapOnSubExp tv arg <*> pure d + Apply fname args' <$> mapM (mapOnRetType tv) ret <*> pure loc +mapExpM tv (BasicOp (Index arr slice)) = + BasicOp <$> (Index <$> mapOnVName tv arr <*> + mapM (traverse (mapOnSubExp tv)) slice) +mapExpM tv (BasicOp (Update arr slice se)) = + BasicOp <$> (Update <$> mapOnVName tv arr <*> + mapM (traverse (mapOnSubExp tv)) slice <*> mapOnSubExp tv se) +mapExpM tv (BasicOp (Iota n x s et)) = + BasicOp <$> (Iota <$> mapOnSubExp tv n <*> mapOnSubExp tv x <*> mapOnSubExp tv s <*> pure et) +mapExpM tv (BasicOp (Replicate shape vexp)) = + BasicOp <$> (Replicate <$> mapOnShape tv shape <*> mapOnSubExp tv vexp) +mapExpM tv (BasicOp (Repeat shapes innershape v)) = + BasicOp <$> (Repeat <$> mapM (mapOnShape tv) shapes <*> + mapOnShape tv innershape <*> mapOnVName tv v) +mapExpM tv (BasicOp (Scratch t shape)) = + BasicOp <$> (Scratch t <$> mapM (mapOnSubExp tv) shape) +mapExpM tv (BasicOp (Reshape shape arrexp)) = + BasicOp <$> (Reshape <$> + mapM (Data.Traversable.traverse (mapOnSubExp tv)) shape <*> + mapOnVName tv arrexp) +mapExpM tv (BasicOp (Rearrange perm e)) = + BasicOp <$> (Rearrange perm <$> mapOnVName tv e) +mapExpM tv (BasicOp (Rotate es e)) = + BasicOp <$> (Rotate <$> mapM (mapOnSubExp tv) es <*> mapOnVName tv e) +mapExpM tv (BasicOp (Concat i x ys size)) = + BasicOp <$> (Concat i <$> + mapOnVName tv x <*> mapM (mapOnVName tv) ys <*> + mapOnSubExp tv size) +mapExpM tv (BasicOp (Copy e)) = + BasicOp <$> (Copy <$> mapOnVName tv e) +mapExpM tv (BasicOp (Manifest perm e)) = + BasicOp <$> (Manifest perm <$> mapOnVName tv e) +mapExpM tv (BasicOp (Assert e msg loc)) = + BasicOp <$> (Assert <$> mapOnSubExp tv e <*> traverse (mapOnSubExp tv) msg <*> pure loc) +mapExpM tv (BasicOp (Opaque e)) = + BasicOp <$> (Opaque <$> mapOnSubExp tv e) +mapExpM tv (DoLoop ctxmerge valmerge form loopbody) = do + ctxparams' <- mapM (mapOnFParam tv) ctxparams + valparams' <- mapM (mapOnFParam tv) valparams + form' <- mapOnLoopForm tv form + let scope = scopeOf form' <> scopeOfFParams (ctxparams'++valparams') + DoLoop <$> + (zip ctxparams' <$> mapM (mapOnSubExp tv) ctxinits) <*> + (zip valparams' <$> mapM (mapOnSubExp tv) valinits) <*> + pure form' <*> mapOnBody tv scope loopbody + where (ctxparams,ctxinits) = unzip ctxmerge + (valparams,valinits) = unzip valmerge +mapExpM tv (Op op) = + Op <$> mapOnOp tv op + +mapOnShape :: Monad m => Mapper flore tlore m -> Shape -> m Shape +mapOnShape tv (Shape ds) = Shape <$> mapM (mapOnSubExp tv) ds + +mapOnLoopForm :: Monad m => + Mapper flore tlore m -> LoopForm flore -> m (LoopForm tlore) +mapOnLoopForm tv (ForLoop i it bound loop_vars) = + ForLoop <$> mapOnVName tv i <*> pure it <*> mapOnSubExp tv bound <*> + (zip <$> mapM (mapOnLParam tv) loop_lparams <*> mapM (mapOnVName tv) loop_arrs) + where (loop_lparams,loop_arrs) = unzip loop_vars +mapOnLoopForm tv (WhileLoop cond) = + WhileLoop <$> mapOnVName tv cond + +-- | Like 'mapExpM', but in the 'Identity' monad. +mapExp :: Mapper flore tlore Identity -> Exp flore -> Exp tlore +mapExp m = runIdentity . mapExpM m + +-- | Transform any t'SubExp's in the type. +mapOnType :: Monad m => + (SubExp -> m SubExp) -> Type -> m Type +mapOnType _ (Prim bt) = return $ Prim bt +mapOnType _ (Mem space) = pure $ Mem space +mapOnType f (Array bt shape u) = + Array bt <$> (Shape <$> mapM f (shapeDims shape)) <*> pure u + +-- | Express a monad expression on a syntax node. Each element of +-- this structure expresses the action to be performed on a given +-- child. +data Walker lore m = Walker { + walkOnSubExp :: SubExp -> m () + , walkOnBody :: Body lore -> m () + , walkOnVName :: VName -> m () + , walkOnRetType :: RetType lore -> m () + , walkOnBranchType :: BranchType lore -> m () + , walkOnFParam :: FParam lore -> m () + , walkOnLParam :: LParam lore -> m () + , walkOnOp :: Op lore -> m () + } + +-- | A no-op traversal. +identityWalker :: Monad m => Walker lore m +identityWalker = Walker { + walkOnSubExp = const $ return () + , walkOnBody = const $ return () + , walkOnVName = const $ return () + , walkOnRetType = const $ return () + , walkOnBranchType = const $ return () + , walkOnFParam = const $ return () + , walkOnLParam = const $ return () + , walkOnOp = const $ return () + } + +walkOnShape :: Monad m => Walker lore m -> Shape -> m () +walkOnShape tv (Shape ds) = mapM_ (walkOnSubExp tv) ds + +walkOnType :: Monad m => + (SubExp -> m ()) -> Type -> m () +walkOnType _ Prim{} = return () +walkOnType _ Mem{} = return () +walkOnType f (Array _ shape _) = mapM_ f $ shapeDims shape + +walkOnLoopForm :: Monad m => Walker lore m -> LoopForm lore -> m () +walkOnLoopForm tv (ForLoop i _ bound loop_vars) = + walkOnVName tv i >> walkOnSubExp tv bound >> + mapM_ (walkOnLParam tv) loop_lparams >> mapM_ (walkOnVName tv) loop_arrs + where (loop_lparams,loop_arrs) = unzip loop_vars +walkOnLoopForm tv (WhileLoop cond) = + walkOnVName tv cond + +-- | As 'mapExpM', but do not construct a result AST. +walkExpM :: Monad m => Walker lore m -> Exp lore -> m () +walkExpM tv (BasicOp (SubExp se)) = + walkOnSubExp tv se +walkExpM tv (BasicOp (ArrayLit els rowt)) = + mapM_ (walkOnSubExp tv) els >> walkOnType (walkOnSubExp tv) rowt +walkExpM tv (BasicOp (BinOp _ x y)) = + walkOnSubExp tv x >> walkOnSubExp tv y +walkExpM tv (BasicOp (CmpOp _ x y)) = + walkOnSubExp tv x >> walkOnSubExp tv y +walkExpM tv (BasicOp (ConvOp _ x)) = + walkOnSubExp tv x +walkExpM tv (BasicOp (UnOp _ x)) = + walkOnSubExp tv x +walkExpM tv (If c texp fexp (IfDec ts _)) = + walkOnSubExp tv c >> walkOnBody tv texp >> + walkOnBody tv fexp >> mapM_ (walkOnBranchType tv) ts +walkExpM tv (Apply _ args ret _) = + mapM_ (walkOnSubExp tv . fst) args >> mapM_ (walkOnRetType tv) ret +walkExpM tv (BasicOp (Index arr slice)) = + walkOnVName tv arr >> mapM_ (traverse_ (walkOnSubExp tv)) slice +walkExpM tv (BasicOp (Update arr slice se)) = + walkOnVName tv arr >> + mapM_ (traverse_ (walkOnSubExp tv)) slice >> + walkOnSubExp tv se +walkExpM tv (BasicOp (Iota n x s _)) = + walkOnSubExp tv n >> walkOnSubExp tv x >> walkOnSubExp tv s +walkExpM tv (BasicOp (Replicate shape vexp)) = + walkOnShape tv shape >> walkOnSubExp tv vexp +walkExpM tv (BasicOp (Repeat shapes innershape v)) = + mapM_ (walkOnShape tv) shapes >> walkOnShape tv innershape >> walkOnVName tv v +walkExpM tv (BasicOp (Scratch _ shape)) = + mapM_ (walkOnSubExp tv) shape +walkExpM tv (BasicOp (Reshape shape arrexp)) = + mapM_ (traverse_ (walkOnSubExp tv)) shape >> walkOnVName tv arrexp +walkExpM tv (BasicOp (Rearrange _ e)) = + walkOnVName tv e +walkExpM tv (BasicOp (Rotate es e)) = + mapM_ (walkOnSubExp tv) es >> walkOnVName tv e +walkExpM tv (BasicOp (Concat _ x ys size)) = + walkOnVName tv x >> mapM_ (walkOnVName tv) ys >> walkOnSubExp tv size +walkExpM tv (BasicOp (Copy e)) = + walkOnVName tv e +walkExpM tv (BasicOp (Manifest _ e)) = + walkOnVName tv e +walkExpM tv (BasicOp (Assert e msg _)) = + walkOnSubExp tv e >> traverse_ (walkOnSubExp tv) msg +walkExpM tv (BasicOp (Opaque e)) = + walkOnSubExp tv e +walkExpM tv (DoLoop ctxmerge valmerge form loopbody) = do + mapM_ (walkOnFParam tv) ctxparams + mapM_ (walkOnFParam tv) valparams + walkOnLoopForm tv form + mapM_ (walkOnSubExp tv) ctxinits + mapM_ (walkOnSubExp tv) valinits + walkOnBody tv loopbody + where (ctxparams,ctxinits) = unzip ctxmerge + (valparams,valinits) = unzip valmerge +walkExpM tv (Op op) = + walkOnOp tv op diff --git a/src/Futhark/Internalise.hs b/src/Futhark/Internalise.hs --- a/src/Futhark/Internalise.hs +++ b/src/Futhark/Internalise.hs @@ -2,8 +2,8 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Safe #-} {-# LANGUAGE Strict #-} -{-# LANGUAGE StrictData #-} -- | -- -- This module implements a transformation from source to core @@ -18,15 +18,14 @@ import qualified Data.Set as S import Data.List (find, intercalate, intersperse, nub, transpose) import qualified Data.List.NonEmpty as NE -import Data.Loc import Language.Futhark as E hiding (TypeArg) import Language.Futhark.Semantic (Imports) -import Futhark.Representation.SOACS as I hiding (stmPattern) +import Futhark.IR.SOACS as I hiding (stmPattern) import Futhark.Transform.Rename as I import Futhark.MonadFreshNames import Futhark.Tools -import Futhark.Representation.AST.Attributes.Aliases +import Futhark.IR.Prop.Aliases import qualified Futhark.Analysis.Alias as Alias import Futhark.Util (splitAt3) @@ -156,7 +155,7 @@ -- We replace all shape annotations, so there should be no constant -- parameters here. params_fresh <- mapM allDimsFreshInPat params - let tparams = map (`E.TypeParamDim` noLoc) $ S.toList $ + let tparams = map (`E.TypeParamDim` mempty) $ S.toList $ mconcat $ map E.patternDimNames params_fresh bindingParams tparams params_fresh $ \shapeparams params' -> do entry_rettype <- internaliseEntryReturnType $ anySizes rettype @@ -578,7 +577,7 @@ return loop_res where - sparams' = map (`TypeParamDim` noLoc) sparams + sparams' = map (`TypeParamDim` mempty) sparams forLoop nested_mergepat shapepat mergeinit form' = do let mergepat' = concat nested_mergepat @@ -639,10 +638,10 @@ (loop_initial_cond, init_loop_cond_bnds) <- collectStms $ do forM_ (zip shapepat shapeinit) $ \(p, se) -> - letBindNames_ [paramName p] $ BasicOp $ SubExp se + letBindNames [paramName p] $ BasicOp $ SubExp se forM_ (zip (concat nested_mergepat) mergeinit) $ \(p, se) -> unless (se == I.Var (paramName p)) $ - letBindNames_ [paramName p] $ BasicOp $ + letBindNames [paramName p] $ BasicOp $ case se of I.Var v | not $ primType $ paramType p -> Reshape (map DimCoercion $ arrayDims $ paramType p) v _ -> SubExp se @@ -663,10 +662,10 @@ loop_end_cond_body <- renameBody <=< insertStmsM $ do forM_ (zip shapepat shapeargs) $ \(p, se) -> unless (se == I.Var (paramName p)) $ - letBindNames_ [paramName p] $ BasicOp $ SubExp se + letBindNames [paramName p] $ BasicOp $ SubExp se forM_ (zip (concat nested_mergepat) ses) $ \(p, se) -> unless (se == I.Var (paramName p)) $ - letBindNames_ [paramName p] $ BasicOp $ + letBindNames [paramName p] $ BasicOp $ case se of I.Var v | not $ primType $ paramType p -> Reshape (map DimCoercion $ arrayDims $ paramType p) v _ -> SubExp se @@ -721,6 +720,14 @@ where mkUnsafe env | envSafe env = env | otherwise = env { envDoBoundsChecks = False } +internaliseExp desc (E.Attr (AttrInfo attr) e _) = + local f $ internaliseExp desc e + where f env | attr == "unsafe", + not $ envSafe env = + env { envDoBoundsChecks = False } + | otherwise = + env { envAttrs = oneAttr (AttrAtom attr) <> envAttrs env } + internaliseExp desc (E.Assert e1 e2 (Info check) loc) = do e1' <- internaliseExp1 "assert_cond" e1 c <- assertingOne $ letExp "assert_c" $ @@ -729,7 +736,7 @@ certifying c $ mapM rebind =<< internaliseExp desc e2 where rebind v = do v' <- newVName "assert_res" - letBindNames_ [v'] $ I.BasicOp $ I.SubExp v + letBindNames [v'] $ I.BasicOp $ I.SubExp v return $ I.Var v' internaliseExp _ (E.Constr c es (Info (E.Scalar (E.Sum fs))) _) = do @@ -849,7 +856,7 @@ internaliseArg desc (arg, argdim) = do arg' <- internaliseExp desc arg case (arg', argdim) of - ([se], Just d) -> letBindNames_ [d] $ BasicOp $ SubExp se + ([se], Just d) -> letBindNames [d] $ BasicOp $ SubExp se _ -> return () return arg' @@ -936,7 +943,7 @@ stmPattern p t $ \pat_names match -> do ses' <- match loc ses forM_ (zip pat_names ses') $ \(v,se) -> - letBindNames_ [v] $ I.BasicOp $ I.SubExp se + letBindNames [v] $ I.BasicOp $ I.SubExp se m body internaliseSlice :: SrcLoc @@ -1125,10 +1132,10 @@ -- Synthesize neutral elements by applying the fold function -- to an empty chunk. - letBindNames_ [I.paramName chunk_param] $ + letBindNames [I.paramName chunk_param] $ I.BasicOp $ I.SubExp $ constant (0::Int32) forM_ lam_val_params $ \p -> - letBindNames_ [I.paramName p] $ + letBindNames [I.paramName p] $ I.BasicOp $ I.Scratch (I.elemType $ I.paramType p) $ I.arrayDims $ I.paramType p accs <- bodyBind =<< renameBody lam_body @@ -1431,10 +1438,10 @@ -- Short-circuiting operators are magical. handleOps [x,y] "&&" = Just $ \desc -> internaliseExp desc $ - E.If x y (E.Literal (E.BoolValue False) noLoc) (Info $ E.Scalar $ E.Prim E.Bool, Info []) noLoc + E.If x y (E.Literal (E.BoolValue False) mempty) (Info $ E.Scalar $ E.Prim E.Bool, Info []) mempty handleOps [x,y] "||" = Just $ \desc -> internaliseExp desc $ - E.If x (E.Literal (E.BoolValue True) noLoc) y (Info $ E.Scalar $ E.Prim E.Bool, Info []) noLoc + E.If x (E.Literal (E.BoolValue True) mempty) y (Info $ E.Scalar $ E.Prim E.Bool, Info []) mempty -- Handle equality and inequality specially, to treat the case of -- arrays. @@ -1733,7 +1740,8 @@ "\nFunction has parameters\n " ++ pretty fun_params Just ts -> do safety <- askSafety - ses <- letTupExp' desc $ + attrs <- asks envAttrs + ses <- attributing attrs $ letTupExp' desc $ I.Apply fname' (zip args' diets) ts (safety, loc, mempty) return (ses, map I.fromDecl ts) @@ -1755,7 +1763,7 @@ combine' _ _ = mempty forM_ (M.toList $ mconcat $ zipWith combine ts ses_ts) $ \(v, se) -> - letBindNames_ [v] $ BasicOp $ SubExp se + letBindNames [v] $ BasicOp $ SubExp se askSafety :: InternaliseM Safety askSafety = do check <- asks envDoBoundsChecks diff --git a/src/Futhark/Internalise/AccurateSizes.hs b/src/Futhark/Internalise/AccurateSizes.hs --- a/src/Futhark/Internalise/AccurateSizes.hs +++ b/src/Futhark/Internalise/AccurateSizes.hs @@ -1,10 +1,8 @@ {-# LANGUAGE FlexibleContexts #-} module Futhark.Internalise.AccurateSizes - ( shapeBody - , argShapes + ( argShapes , ensureResultShape , ensureResultExtShape - , ensureResultExtShapeNoCtx , ensureExtShape , ensureShape , ensureArgShapes @@ -12,21 +10,11 @@ where import Control.Monad -import Data.Loc import qualified Data.Map.Strict as M import qualified Data.Set as S import Futhark.Construct -import Futhark.Representation.AST - -shapeBody :: (HasScope lore m, MonadFreshNames m, BinderOps lore, Bindable lore) => - [VName] -> [Type] -> Body lore - -> m (Body lore) -shapeBody shapenames ts body = - runBodyBinder $ do - ses <- bodyBind body - sets <- mapM subExpType ses - resultBodyM $ argShapes shapenames ts sets +import Futhark.IR argShapes :: [VName] -> [TypeBase Shape u0] -> [TypeBase Shape u1] -> [SubExp] argShapes shapes valts valargts = diff --git a/src/Futhark/Internalise/Bindings.hs b/src/Futhark/Internalise/Bindings.hs --- a/src/Futhark/Internalise/Bindings.hs +++ b/src/Futhark/Internalise/Bindings.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Safe #-} module Futhark.Internalise.Bindings ( -- * Internalising bindings @@ -15,10 +16,9 @@ import qualified Data.Map.Strict as M import qualified Data.Set as S -import Data.Loc import Language.Futhark as E hiding (matchDims) -import qualified Futhark.Representation.SOACS as I +import qualified Futhark.IR.SOACS as I import Futhark.MonadFreshNames import Futhark.Internalise.Monad import Futhark.Internalise.TypesValues @@ -171,7 +171,7 @@ return $ t `I.setArrayShape` I.Shape new_dims where inspectDim (I.Free (I.Var v)) d | v `S.member` tparam_names = do - letBindNames_ [v] $ I.BasicOp $ I.SubExp d + letBindNames [v] $ I.BasicOp $ I.SubExp d return $ I.Free $ I.Var v inspectDim ed _ = return ed diff --git a/src/Futhark/Internalise/Defunctionalise.hs b/src/Futhark/Internalise/Defunctionalise.hs --- a/src/Futhark/Internalise/Defunctionalise.hs +++ b/src/Futhark/Internalise/Defunctionalise.hs @@ -1,5 +1,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Trustworthy #-} -- | Defunctionalization of typed, monomorphic Futhark programs without modules. module Futhark.Internalise.Defunctionalise ( transformProg ) where @@ -11,7 +12,6 @@ import Data.Foldable import Data.List (sortOn, nub, partition, tails) import qualified Data.List.NonEmpty as NE -import Data.Loc import Data.Maybe import qualified Data.Map.Strict as M import qualified Data.Set as S @@ -19,7 +19,7 @@ import Futhark.MonadFreshNames import Language.Futhark -import Futhark.Representation.AST.Pretty () +import Futhark.IR.Pretty () -- | An expression or an extended 'Lambda' (with size parameters, -- which AST lambdas do not support). @@ -189,13 +189,13 @@ where closureFromDynamicFun (vn, DynamicFun (clsr_env, sv) _) = let name = nameFromString $ pretty vn - in (RecordFieldExplicit name clsr_env noLoc, (vn, sv)) + in (RecordFieldExplicit name clsr_env mempty, (vn, sv)) closureFromDynamicFun (vn, sv) = let name = nameFromString $ pretty vn tp' = typeFromSV sv in (RecordFieldExplicit name - (Var (qualName vn) (Info tp') noLoc) noLoc, (vn, sv)) + (Var (qualName vn) (Info tp') mempty) mempty, (vn, sv)) -- | Defunctionalization of an expression. Returns the residual expression and -- the associated static value in the defunctionalization monad. @@ -267,7 +267,7 @@ -- can get rid of them. IntrinsicSV -> do (pats, body, tp) <- etaExpand (typeOf e) e - defuncExp $ Lambda pats body Nothing (Info (mempty, tp)) noLoc + defuncExp $ Lambda pats body Nothing (Info (mempty, tp)) mempty _ -> let tp = typeFromSV sv in return (Var qn (Info tp) loc, sv) @@ -442,6 +442,10 @@ sv' = snd $ NE.head csPairs return (Match e' cs' t loc, sv') +defuncExp (Attr info e loc) = do + (e', sv) <- defuncExp e + return (Attr info e' loc, sv) + -- | Same as 'defuncExp', except it ignores the static value. defuncExp' :: Exp -> DefM Exp defuncExp' = fmap fst . defuncExp @@ -479,7 +483,7 @@ (pats, body, tp) <- etaExpand (typeOf e) e let env = foldMap envFromPattern pats body' <- localEnv env $ defuncExp' body - return $ Lambda pats body' Nothing (Info (mempty, tp)) noLoc + return $ Lambda pats body' Nothing (Info (mempty, tp)) mempty | otherwise = defuncExp' e etaExpand :: PatternType -> Exp -> DefM ([Pattern], Exp, StructType) @@ -488,11 +492,11 @@ (pats, vars) <- fmap unzip . forM ps $ \(p, t) -> do x <- case p of Named x -> pure x Unnamed -> newNameFromString "x" - return (Id x (Info t) noLoc, - Var (qualName x) (Info t) noLoc) + return (Id x (Info t) mempty, + Var (qualName x) (Info t) mempty) let e' = foldl' (\e1 (e2, t2, argtypes) -> Apply e1 e2 (Info (diet t2, Nothing)) - (Info (foldFunType argtypes ret), Info []) noLoc) + (Info (foldFunType argtypes ret), Info []) mempty) e $ zip3 vars (map snd ps) (drop 1 $ tails $ map snd ps) return (pats, e', toStruct ret) @@ -519,10 +523,10 @@ (pat_dims, rest_dims) = partition bound_by_pat dims env = envFromPattern pat <> envFromShapeParams pat_dims (rest_dims', pats', body', sv) <- localEnv env $ defuncLet rest_dims pats body rettype - closure <- defuncFun dims ps body (mempty, rettype) noLoc + closure <- defuncFun dims ps body (mempty, rettype) mempty return (pat_dims ++ rest_dims', pat : pats', body', DynamicFun closure sv) | otherwise = do - (e, sv) <- defuncFun dims ps body (mempty, rettype) noLoc + (e, sv) <- defuncFun dims ps body (mempty, rettype) mempty return ([], [], e, sv) defuncLet _ [] body rettype = do @@ -598,7 +602,7 @@ (Info $ Scalar $ Arrow mempty Unnamed (fromStruct t2) rettype, Info []) loc) - e2' d callret loc) noLoc, sv) + e2' d callret loc) mempty, sv) -- If e1 is a dynamic function, we just leave the application in place, -- but we update the types since it may be partially applied or return @@ -625,7 +629,7 @@ if null argtypes then return (e', Dynamic $ typeOf e) else do (pats, body, tp) <- etaExpand (typeOf e') e' - defuncExp $ Lambda pats body Nothing (Info (mempty, tp)) noLoc + defuncExp $ Lambda pats body Nothing (Info (mempty, tp)) mempty | otherwise -> return (e', IntrinsicSV) _ -> error $ "Application of an expression that is neither a static lambda " @@ -710,7 +714,7 @@ -- return type, list of parameters, and body expression. liftValDec :: VName -> PatternType -> [VName] -> [Pattern] -> Exp -> DefM () liftValDec fname rettype dims pats body = tell $ Seq.singleton dec - where dims' = map (flip TypeParamDim noLoc) dims + where dims' = map (`TypeParamDim` mempty) dims -- FIXME: this pass is still not correctly size-preserving, so -- forget those return sizes that we forgot to propagate along -- the way. Hopefully the internaliser is conservative and @@ -731,16 +735,16 @@ , valBindParams = pats , valBindBody = body , valBindDoc = Nothing - , valBindLocation = noLoc + , valBindLocation = mempty } -- | Given a closure environment, construct a record pattern that -- binds the closed over variables. buildEnvPattern :: Env -> Pattern -buildEnvPattern env = RecordPattern (map buildField $ M.toList env) noLoc +buildEnvPattern env = RecordPattern (map buildField $ M.toList env) mempty where buildField (vn, sv) = (nameFromString (pretty vn), - Id vn (Info $ typeFromSV sv) noLoc) + Id vn (Info $ typeFromSV sv) mempty) -- | Given a closure environment pattern and the type of a term, -- construct the type of that term, where uniqueness is set to @@ -914,7 +918,7 @@ RecordLit fs _ -> foldMap freeVarsField fs where freeVarsField (RecordFieldExplicit _ e _) = freeVars e - freeVarsField (RecordFieldImplicit vn t _) = ident $ Ident vn t noLoc + freeVarsField (RecordFieldImplicit vn t _) = ident $ Ident vn t mempty ArrayLit es t _ -> foldMap freeVars es <> names (typeDimNames $ unInfo t) @@ -966,6 +970,7 @@ Unsafe e _ -> freeVars e Assert e1 e2 _ _ -> freeVars e1 <> freeVars e2 Constr _ es _ _ -> foldMap freeVars es + Attr _ e _ -> freeVars e Match e cs _ _ -> freeVars e <> foldMap caseFV cs where caseFV (CasePat p eCase _) = (names (patternDimNames p) <> freeVars eCase) `without` patternVars p diff --git a/src/Futhark/Internalise/Defunctorise.hs b/src/Futhark/Internalise/Defunctorise.hs --- a/src/Futhark/Internalise/Defunctorise.hs +++ b/src/Futhark/Internalise/Defunctorise.hs @@ -1,6 +1,7 @@ -- | Partially evaluate all modules away from a source Futhark -- program. This is implemented as a source-to-source transformation. {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE Trustworthy #-} module Futhark.Internalise.Defunctorise (transformProg) where import Control.Monad.RWS.Strict @@ -9,7 +10,6 @@ import qualified Data.Map as M import qualified Data.Set as S import Data.Maybe -import Data.Loc import Prelude hiding (mod, abs) @@ -255,8 +255,8 @@ transformTypeBind :: TypeBind -> TransformM () transformTypeBind (TypeBind name l tparams te doc loc) = do name' <- transformName name - emit =<< TypeDec <$> (TypeBind name' l <$> traverse transformNames tparams - <*> transformTypeDecl te <*> pure doc <*> pure loc) + emit . TypeDec =<< (TypeBind name' l <$> traverse transformNames tparams + <*> transformTypeDecl te <*> pure doc <*> pure loc) transformModBind :: ModBind -> TransformM Scope transformModBind mb = do @@ -318,6 +318,7 @@ else Nothing } maybeHideEntryPoint d = d +-- | Perform defunctorisation. transformProg :: MonadFreshNames m => Imports -> m [Dec] transformProg prog = modifyNameSource $ \namesrc -> let ((), namesrc', prog') = runTransformM namesrc $ transformImports prog diff --git a/src/Futhark/Internalise/Lambdas.hs b/src/Futhark/Internalise/Lambdas.hs --- a/src/Futhark/Internalise/Lambdas.hs +++ b/src/Futhark/Internalise/Lambdas.hs @@ -9,10 +9,8 @@ ) where -import Data.Loc - import Language.Futhark as E -import Futhark.Representation.SOACS as I +import Futhark.IR.SOACS as I import Futhark.MonadFreshNames import Futhark.Internalise.Monad import Futhark.Internalise.AccurateSizes @@ -50,11 +48,11 @@ internaliseLambda lam $ I.Prim int32 : map outer argtypes let orig_chunk_param : params = lam_params body <- runBodyBinder $ do - letBindNames_ [paramName orig_chunk_param] $ I.BasicOp $ I.SubExp $ I.Var chunk_size + letBindNames [paramName orig_chunk_param] $ I.BasicOp $ I.SubExp $ I.Var chunk_size return orig_body (rettype', _) <- instantiateShapes' rettype body' <- localScope (scopeOfLParams params) $ insertStmsM $ do - letBindNames_ [paramName orig_chunk_param] $ I.BasicOp $ I.SubExp $ I.Var chunk_size + letBindNames [paramName orig_chunk_param] $ I.BasicOp $ I.SubExp $ I.Var chunk_size ensureResultShape asserting (ErrorMsg [ErrorString "not all iterations produce same shape"]) (srclocOf lam) (map outer rettype') body @@ -91,7 +89,7 @@ internaliseLambda lam $ I.Prim int32 : chunktypes let orig_chunk_param : params = lam_params body <- runBodyBinder $ do - letBindNames_ [paramName orig_chunk_param] $ I.BasicOp $ I.SubExp $ I.Var chunk_size + letBindNames [paramName orig_chunk_param] $ I.BasicOp $ I.SubExp $ I.Var chunk_size return orig_body return (chunk_param:params, body) diff --git a/src/Futhark/Internalise/Monad.hs b/src/Futhark/Internalise/Monad.hs --- a/src/Futhark/Internalise/Monad.hs +++ b/src/Futhark/Internalise/Monad.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleInstances, TypeFamilies, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-} +{-# LANGUAGE Trustworthy #-} module Futhark.Internalise.Monad ( InternaliseM , runInternaliseM @@ -45,7 +46,7 @@ import Control.Monad.RWS import qualified Data.Map.Strict as M -import Futhark.Representation.SOACS +import Futhark.IR.SOACS import Futhark.MonadFreshNames import Futhark.Tools import Futhark.Util (takeLast) @@ -69,6 +70,7 @@ envSubsts :: VarSubstitutions , envDoBoundsChecks :: Bool , envSafe :: Bool + , envAttrs :: Attrs } data InternaliseState = InternaliseState { @@ -107,13 +109,12 @@ instance MonadBinder InternaliseM where type Lore InternaliseM = SOACS - mkExpAttrM pat e = InternaliseM $ mkExpAttrM pat e + mkExpDecM pat e = InternaliseM $ mkExpDecM pat e mkBodyM bnds res = InternaliseM $ mkBodyM bnds res mkLetNamesM pat e = InternaliseM $ mkLetNamesM pat e addStms = InternaliseM . addStms collectStms (InternaliseM m) = InternaliseM $ collectStms m - certifying cs (InternaliseM m) = InternaliseM $ certifying cs m runInternaliseM :: MonadFreshNames m => Bool -> InternaliseM () @@ -127,6 +128,7 @@ envSubsts = mempty , envDoBoundsChecks = True , envSafe = safe + , envAttrs = mempty } newState src = InternaliseState { stateNameSource = src @@ -226,4 +228,4 @@ withDims dtable = local $ \env -> env { typeEnvDims = dtable <> typeEnvDims env } lookupDim :: VName -> InternaliseTypeM (Maybe ExtSize) -lookupDim name = M.lookup name <$> asks typeEnvDims +lookupDim name = asks $ M.lookup name . typeEnvDims diff --git a/src/Futhark/Internalise/Monomorphise.hs b/src/Futhark/Internalise/Monomorphise.hs --- a/src/Futhark/Internalise/Monomorphise.hs +++ b/src/Futhark/Internalise/Monomorphise.hs @@ -1,4 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE Trustworthy #-} -- | This monomorphization module converts a well-typed, polymorphic, -- module-free Futhark program into an equivalent monomorphic program. -- @@ -21,11 +23,8 @@ -- -- Note that these changes are unfortunately not visible in the AST -- representation. -{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Futhark.Internalise.Monomorphise - ( transformProg - , transformDecs - ) where + ( transformProg ) where import Control.Monad.RWS hiding (Sum) import Control.Monad.State @@ -33,7 +32,6 @@ import Data.Bitraversable import Data.Bifunctor import Data.List (partition) -import Data.Loc import qualified Data.Map.Strict as M import Data.Maybe import qualified Data.Set as S @@ -49,8 +47,9 @@ i32 :: TypeBase dim als i32 = Scalar $ Prim $ Signed Int32 --- | The monomorphization monad reads 'PolyBinding's and writes 'ValBinding's. --- The 'TypeParam's in a 'ValBinding' can only be shape parameters. +-- The monomorphization monad reads 'PolyBinding's and writes +-- 'ValBind's. The 'TypeParam's in the 'ValBind's can only be size +-- parameters. -- -- Each 'Polybinding' is also connected with the 'RecordReplacements' -- that were active when the binding was defined. This is used only @@ -59,15 +58,15 @@ (VName, [TypeParam], [Pattern], Maybe (TypeExp VName), StructType, [VName], Exp, SrcLoc) --- | Mapping from record names to the variable names that contain the +-- Mapping from record names to the variable names that contain the -- fields. This is used because the monomorphiser also expands all -- record patterns. type RecordReplacements = M.Map VName RecordReplacement type RecordReplacement = M.Map Name (VName, PatternType) --- | Monomorphization environment mapping names of polymorphic functions to a --- representation of their corresponding function bindings. +-- Monomorphization environment mapping names of polymorphic functions +-- to a representation of their corresponding function bindings. data Env = Env { envPolyBindings :: M.Map VName PolyBinding , envTypeBindings :: M.Map VName TypeBinding , envRecordReplacements :: RecordReplacements @@ -92,7 +91,7 @@ replaceRecordReplacements :: RecordReplacements -> MonoM a -> MonoM a replaceRecordReplacements rr = local $ \env -> env { envRecordReplacements = rr } --- | The monomorphization monad. +-- The monomorphization monad. newtype MonoM a = MonoM (RWST Env (Seq.Seq (VName, ValBind)) VNameSource (State Lifts) a) deriving (Functor, Applicative, Monad, @@ -114,10 +113,10 @@ lookupRecordReplacement :: VName -> MonoM (Maybe RecordReplacement) lookupRecordReplacement v = asks $ M.lookup v . envRecordReplacements --- | Given instantiated type of function, produce size arguments. +-- Given instantiated type of function, produce size arguments. type InferSizeArgs = StructType -> [Exp] --- | The kind of type relative to which we monomorphise. What is +-- The kind of type relative to which we monomorphise. What is -- important to us is not the specific dimensions, but merely whether -- they are known or anonymous (the latter False). type MonoType = TypeBase Bool () @@ -127,7 +126,7 @@ where onDim AnyDim = False onDim _ = True --- | Mapping from function name and instance list to a new function name in case +-- Mapping from function name and instance list to a new function name in case -- the function has already been instantiated with those concrete types. type Lifts = [((VName, MonoType), (VName, InferSizeArgs))] @@ -180,7 +179,7 @@ loc) size_args --- | This carries out record replacements in the alias information of a type. +-- This carries out record replacements in the alias information of a type. transformType :: TypeBase dim Aliasing -> MonoM (TypeBase dim Aliasing) transformType t = do rrs <- asks envRecordReplacements @@ -193,7 +192,7 @@ then second (mconcat . map replace . S.toList) t else t --- | Monomorphization of expressions. +-- Monomorphization of expressions. transformExp :: Exp -> MonoM Exp transformExp e@Literal{} = return e transformExp e@IntLit{} = return e @@ -345,8 +344,8 @@ (y_param_e, y_param) <- makeVarParam e2' return $ LetPat x_param e1' (LetPat y_param e2' - (applyOp fname' x_param_e y_param_e) (tp, Info mempty) noLoc) - (tp, Info mempty) noLoc + (applyOp fname' x_param_e y_param_e) (tp, Info mempty) mempty) + (tp, Info mempty) mempty where applyOp fname' x y = Apply (Apply fname' x (Info (Observe, snd (unInfo d1))) (Info (foldFunType [fromStruct $ fst (unInfo d2)] (unInfo tp)), @@ -356,8 +355,8 @@ makeVarParam arg = do let argtype = typeOf arg x <- newNameFromString "binop_p" - return (Var (qualName x) (Info argtype) noLoc, - Id x (Info $ fromStruct argtype) noLoc) + return (Var (qualName x) (Info argtype) mempty, + Id x (Info $ fromStruct argtype) mempty) transformExp (Project n e tp loc) = do @@ -402,10 +401,13 @@ Match <$> transformExp e <*> mapM transformCase cs <*> ((,) <$> traverse transformType t <*> pure retext) <*> pure loc +transformExp (Attr info e loc) = + Attr info <$> transformExp e <*> pure loc + transformCase :: Case -> MonoM Case transformCase (CasePat p e loc) = do (p', rr) <- transformPattern p - CasePat <$> pure p' <*> withRecordReplacements rr (transformExp e) <*> pure loc + CasePat p' <$> withRecordReplacements rr (transformExp e) <*> pure loc transformDimIndex :: DimIndexBase Info VName -> MonoM (DimIndexBase Info VName) transformDimIndex (DimFix e) = DimFix <$> transformExp e @@ -413,7 +415,7 @@ DimSlice <$> trans me1 <*> trans me2 <*> trans me3 where trans = mapM transformExp --- | Transform an operator section into a lambda. +-- Transform an operator section into a lambda. desugarBinOpSection :: Exp -> Maybe Exp -> Maybe Exp -> PatternType -> (StructType, Maybe VName) -> (StructType, Maybe VName) @@ -431,19 +433,19 @@ where makeVarParam (Just e) _ = return (e, []) makeVarParam Nothing argtype = do x <- newNameFromString "x" - return (Var (qualName x) (Info argtype) noLoc, - [Id x (Info $ fromStruct argtype) noLoc]) + return (Var (qualName x) (Info argtype) mempty, + [Id x (Info $ fromStruct argtype) mempty]) desugarProjectSection :: [Name] -> PatternType -> SrcLoc -> MonoM Exp desugarProjectSection fields (Scalar (Arrow _ _ t1 t2)) loc = do p <- newVName "project_p" - let body = foldl project (Var (qualName p) (Info t1) noLoc) fields - return $ Lambda [Id p (Info t1) noLoc] body Nothing (Info (mempty, toStruct t2)) loc + let body = foldl project (Var (qualName p) (Info t1) mempty) fields + return $ Lambda [Id p (Info t1) mempty] body Nothing (Info (mempty, toStruct t2)) loc where project e field = case typeOf e of Scalar (Record fs) | Just t <- M.lookup field fs -> - Project field e (Info t) noLoc + Project field e (Info t) mempty t -> error $ "desugarOpSection: type " ++ pretty t ++ " does not have field " ++ pretty field desugarProjectSection _ t _ = error $ "desugarOpSection: not a function type: " ++ pretty t @@ -452,15 +454,15 @@ desugarIndexSection idxs (Scalar (Arrow _ _ t1 t2)) loc = do p <- newVName "index_i" let body = Index (Var (qualName p) (Info t1) loc) idxs (Info t2, Info []) loc - return $ Lambda [Id p (Info t1) noLoc] body Nothing (Info (mempty, toStruct t2)) loc + return $ Lambda [Id p (Info t1) mempty] body Nothing (Info (mempty, toStruct t2)) loc desugarIndexSection _ t _ = error $ "desugarIndexSection: not a function type: " ++ pretty t noticeDims :: TypeBase (DimDecl VName) as -> MonoM () noticeDims = mapM_ notice . nestedDims - where notice (NamedDim v) = void $ transformFName noLoc v i32 + where notice (NamedDim v) = void $ transformFName mempty v i32 notice _ = return () --- | Convert a collection of 'ValBind's to a nested sequence of let-bound, +-- Convert a collection of 'ValBind's to a nested sequence of let-bound, -- monomorphic functions with the given expression at the bottom. unfoldLetFuns :: [ValBind] -> Exp -> Exp unfoldLetFuns [] e = e @@ -524,9 +526,9 @@ where tparamArg dinst tp = case M.lookup (typeParamName tp) dinst of Just (NamedDim d) -> - Just $ Var d (Info i32) noLoc + Just $ Var d (Info i32) mempty Just (ConstDim x) -> - Just $ Literal (SignedValue $ Int32Value $ fromIntegral x) noLoc + Just $ Literal (SignedValue $ Int32Value $ fromIntegral x) mempty _ -> Nothing @@ -558,7 +560,7 @@ Sum $ fmap (map f) cs f' t = t --- | Monomorphise a polymorphic function at the types given in the instance +-- Monomorphise a polymorphic function at the types given in the instance -- list. Monomorphises the body of the function as well. Returns the fresh name -- of the generated monomorphic function and its 'ValBind' representation. monomorphiseBinding :: Bool -> PolyBinding -> MonoType @@ -657,7 +659,7 @@ return $ NamedDim $ qualName d onDim False = return AnyDim --- | Perform a given substitution on the types in a pattern. +-- Perform a given substitution on the types in a pattern. substPattern :: Bool -> (PatternType -> PatternType) -> Pattern -> Pattern substPattern entry f pat = case pat of TuplePattern pats loc -> TuplePattern (map (substPattern entry f) pats) loc @@ -675,7 +677,7 @@ toPolyBinding (ValBind _ name retdecl (Info (rettype, retext)) tparams params body _ loc) = PolyBinding mempty (name, tparams, params, retdecl, rettype, retext, body, loc) --- | Remove all type variables and type abbreviations from a value binding. +-- Remove all type variables and type abbreviations from a value binding. removeTypeVariables :: Bool -> ValBind -> MonoM ValBind removeTypeVariables entry valbind@(ValBind _ _ _ (Info (rettype, retext)) _ pats body _ _) = do subs <- asks $ M.map TypeSub . envTypeBindings diff --git a/src/Futhark/Internalise/TypesValues.hs b/src/Futhark/Internalise/TypesValues.hs --- a/src/Futhark/Internalise/TypesValues.hs +++ b/src/Futhark/Internalise/TypesValues.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE Trustworthy #-} module Futhark.Internalise.TypesValues ( -- * Internalising types @@ -25,7 +26,7 @@ import Data.Maybe import qualified Language.Futhark as E -import Futhark.Representation.SOACS as I +import Futhark.IR.SOACS as I import Futhark.Internalise.Monad internaliseUniqueness :: E.Uniqueness -> I.Uniqueness diff --git a/src/Futhark/MonadFreshNames.hs b/src/Futhark/MonadFreshNames.hs --- a/src/Futhark/MonadFreshNames.hs +++ b/src/Futhark/MonadFreshNames.hs @@ -27,7 +27,7 @@ import qualified Control.Monad.Trans.Maybe import Control.Monad.Reader -import Futhark.Representation.AST.Syntax +import Futhark.IR.Syntax import qualified Futhark.FreshNames as FreshNames import Futhark.FreshNames hiding (newName) @@ -78,7 +78,7 @@ newNameFromString :: MonadFreshNames m => String -> m VName newNameFromString s = newName $ VName (nameFromString s) 0 --- | Produce a fresh 'ID', using the given base name as a template. +-- | Produce a fresh 'VName', using the given base name as a template. newID :: MonadFreshNames m => Name -> m VName newID s = newName $ VName s 0 @@ -104,7 +104,7 @@ -- | Produce a fresh 'Param', using the given name as a template. newParam :: MonadFreshNames m => - String -> attr -> m (Param attr) + String -> dec -> m (Param dec) newParam s t = do s' <- newID $ nameFromString s return $ Param s' t diff --git a/src/Futhark/Optimise/CSE.hs b/src/Futhark/Optimise/CSE.hs --- a/src/Futhark/Optimise/CSE.hs +++ b/src/Futhark/Optimise/CSE.hs @@ -38,19 +38,19 @@ import qualified Data.Map.Strict as M import Futhark.Analysis.Alias -import Futhark.Representation.AST -import Futhark.Representation.AST.Attributes.Aliases -import Futhark.Representation.Aliases +import Futhark.IR +import Futhark.IR.Prop.Aliases +import Futhark.IR.Aliases (removeProgAliases, removeFunDefAliases, removeStmAliases, Aliases, consumedInStms) -import qualified Futhark.Representation.Kernels.Kernel as Kernel -import qualified Futhark.Representation.SOACS.SOAC as SOAC -import qualified Futhark.Representation.Mem as Memory +import qualified Futhark.IR.Kernels.Kernel as Kernel +import qualified Futhark.IR.SOACS.SOAC as SOAC +import qualified Futhark.IR.Mem as Memory import Futhark.Transform.Substitute import Futhark.Pass -- | Perform CSE on every function in a program. -performCSE :: (Attributes lore, CanBeAliased (Op lore), +performCSE :: (ASTLore lore, CanBeAliased (Op lore), CSEInOp (OpWithAliases (Op lore))) => Bool -> Pass lore lore performCSE cse_arrays = @@ -65,14 +65,14 @@ onFun _ = pure . cseInFunDef cse_arrays -- | Perform CSE on a single function. -performCSEOnFunDef :: (Attributes lore, CanBeAliased (Op lore), +performCSEOnFunDef :: (ASTLore lore, CanBeAliased (Op lore), CSEInOp (OpWithAliases (Op lore))) => Bool -> FunDef lore -> FunDef lore performCSEOnFunDef cse_arrays = removeFunDefAliases . cseInFunDef cse_arrays . analyseFun -- | Perform CSE on some statements. -performCSEOnStms :: (Attributes lore, CanBeAliased (Op lore), +performCSEOnStms :: (ASTLore lore, CanBeAliased (Op lore), CSEInOp (OpWithAliases (Op lore))) => Bool -> Stms lore -> Stms lore performCSEOnStms cse_arrays = @@ -82,7 +82,7 @@ (stmsToList stms) (return ())) (newCSEState cse_arrays) -cseInFunDef :: (Attributes lore, Aliased lore, CSEInOp (Op lore)) => +cseInFunDef :: (ASTLore lore, Aliased lore, CSEInOp (Op lore)) => Bool -> FunDef lore -> FunDef lore cseInFunDef cse_arrays fundec = fundec { funDefBody = @@ -92,25 +92,25 @@ type CSEM lore = Reader (CSEState lore) -cseInBody :: (Attributes lore, Aliased lore, CSEInOp (Op lore)) => +cseInBody :: (ASTLore lore, Aliased lore, CSEInOp (Op lore)) => [Diet] -> Body lore -> CSEM lore (Body lore) -cseInBody ds (Body bodyattr bnds res) = do +cseInBody ds (Body bodydec bnds res) = do (bnds', res') <- cseInStms (res_cons <> consumedInStms bnds) (stmsToList bnds) $ do CSEState (_, nsubsts) _ <- ask return $ substituteNames nsubsts res - return $ Body bodyattr bnds' res' + return $ Body bodydec bnds' res' where res_cons = mconcat $ zipWith consumeResult ds res consumeResult Consume se = freeIn se consumeResult _ _ = mempty -cseInLambda :: (Attributes lore, Aliased lore, CSEInOp (Op lore)) => +cseInLambda :: (ASTLore lore, Aliased lore, CSEInOp (Op lore)) => Lambda lore -> CSEM lore (Lambda lore) cseInLambda lam = do body' <- cseInBody (map (const Observe) $ lambdaReturnType lam) $ lambdaBody lam return lam { lambdaBody = body' } -cseInStms :: (Attributes lore, Aliased lore, CSEInOp (Op lore)) => +cseInStms :: (ASTLore lore, Aliased lore, CSEInOp (Op lore)) => Names -> [Stm lore] -> CSEM lore a -> CSEM lore (Stms lore, a) @@ -133,29 +133,29 @@ patElemDiet pe | patElemName pe `nameIn` consumed = Consume | otherwise = Observe -cseInStm :: Attributes lore => +cseInStm :: ASTLore lore => Names -> Stm lore -> ([Stm lore] -> CSEM lore a) -> CSEM lore a -cseInStm consumed (Let pat (StmAux cs eattr) e) m = do +cseInStm consumed (Let pat (StmAux cs attrs edec) e) m = do CSEState (esubsts, nsubsts) cse_arrays <- ask let e' = substituteNames nsubsts e pat' = substituteNames nsubsts pat if any (bad cse_arrays) $ patternValueElements pat then - m [Let pat' (StmAux cs eattr) e'] + m [Let pat' (StmAux cs attrs edec) e'] else - case M.lookup (eattr, e') esubsts of + case M.lookup (edec, e') esubsts of Just subpat -> local (addNameSubst pat' subpat) $ do let lets = - [ Let (Pattern [] [patElem']) (StmAux cs eattr) $ + [ Let (Pattern [] [patElem']) (StmAux cs attrs edec) $ BasicOp $ SubExp $ Var $ patElemName patElem | (name,patElem) <- zip (patternNames pat') $ patternElements subpat , let patElem' = patElem { patElemName = name } ] m lets - _ -> local (addExpSubst pat' eattr e') $ - m [Let pat' (StmAux cs eattr) e'] + _ -> local (addExpSubst pat' edec e') $ + m [Let pat' (StmAux cs attrs edec) e'] where bad cse_arrays pe | Mem{} <- patElemType pe = True @@ -164,7 +164,7 @@ | otherwise = False type ExpressionSubstitutions lore = M.Map - (ExpAttr lore, Exp lore) + (ExpDec lore, Exp lore) (Pattern lore) type NameSubstitutions = M.Map VName VName @@ -176,19 +176,19 @@ newCSEState :: Bool -> CSEState lore newCSEState = CSEState (M.empty, M.empty) -mkSubsts :: PatternT attr -> PatternT attr -> M.Map VName VName +mkSubsts :: PatternT dec -> PatternT dec -> M.Map VName VName mkSubsts pat vs = M.fromList $ zip (patternNames pat) (patternNames vs) -addNameSubst :: PatternT attr -> PatternT attr -> CSEState lore -> CSEState lore +addNameSubst :: PatternT dec -> PatternT dec -> CSEState lore -> CSEState lore addNameSubst pat subpat (CSEState (esubsts, nsubsts) cse_arrays) = CSEState (esubsts, mkSubsts pat subpat `M.union` nsubsts) cse_arrays -addExpSubst :: Attributes lore => - Pattern lore -> ExpAttr lore -> Exp lore +addExpSubst :: ASTLore lore => + Pattern lore -> ExpDec lore -> Exp lore -> CSEState lore -> CSEState lore -addExpSubst pat eattr e (CSEState (esubsts, nsubsts) cse_arrays) = - CSEState (M.insert (eattr,e) pat esubsts, nsubsts) cse_arrays +addExpSubst pat edec e (CSEState (esubsts, nsubsts) cse_arrays) = + CSEState (M.insert (edec,e) pat esubsts, nsubsts) cse_arrays -- | The operations that permit CSE. class CSEInOp op where @@ -203,29 +203,29 @@ CSEState _ cse_arrays <- ask return $ runReader m $ newCSEState cse_arrays -instance (Attributes lore, Aliased lore, +instance (ASTLore lore, Aliased lore, CSEInOp (Op lore), CSEInOp op) => CSEInOp (Kernel.HostOp lore op) where cseInOp (Kernel.SegOp op) = Kernel.SegOp <$> cseInOp op cseInOp (Kernel.OtherOp op) = Kernel.OtherOp <$> cseInOp op cseInOp x = return x -instance (Attributes lore, Aliased lore, CSEInOp (Op lore)) => +instance (ASTLore lore, Aliased lore, CSEInOp (Op lore)) => CSEInOp (Kernel.SegOp lvl lore) where cseInOp = subCSE . Kernel.mapSegOpM (Kernel.SegOpMapper return cseInLambda cseInKernelBody return return) -cseInKernelBody :: (Attributes lore, Aliased lore, CSEInOp (Op lore)) => +cseInKernelBody :: (ASTLore lore, Aliased lore, CSEInOp (Op lore)) => Kernel.KernelBody lore -> CSEM lore (Kernel.KernelBody lore) -cseInKernelBody (Kernel.KernelBody bodyattr bnds res) = do - Body _ bnds' _ <- cseInBody (map (const Observe) res) $ Body bodyattr bnds [] - return $ Kernel.KernelBody bodyattr bnds' res +cseInKernelBody (Kernel.KernelBody bodydec bnds res) = do + Body _ bnds' _ <- cseInBody (map (const Observe) res) $ Body bodydec bnds [] + return $ Kernel.KernelBody bodydec bnds' res instance CSEInOp op => CSEInOp (Memory.MemOp op) where cseInOp o@Memory.Alloc{} = return o cseInOp (Memory.Inner k) = Memory.Inner <$> subCSE (cseInOp k) -instance (Attributes lore, +instance (ASTLore lore, CanBeAliased (Op lore), CSEInOp (OpWithAliases (Op lore))) => CSEInOp (SOAC.SOAC (Aliases lore)) where diff --git a/src/Futhark/Optimise/DoubleBuffer.hs b/src/Futhark/Optimise/DoubleBuffer.hs --- a/src/Futhark/Optimise/DoubleBuffer.hs +++ b/src/Futhark/Optimise/DoubleBuffer.hs @@ -33,14 +33,15 @@ import Data.List (find) import Futhark.Construct -import Futhark.Representation.AST +import Futhark.IR import Futhark.Pass.ExplicitAllocations (arraySizeInBytesExp) import Futhark.Pass.ExplicitAllocations.Kernels () -import qualified Futhark.Representation.Mem.IxFun as IxFun -import Futhark.Representation.KernelsMem +import qualified Futhark.IR.Mem.IxFun as IxFun +import Futhark.IR.KernelsMem import Futhark.Pass import Futhark.Util (maybeHead) +-- | The double buffering pass definition. doubleBuffer :: Pass KernelsMem KernelsMem doubleBuffer = Pass { passName = "Double buffer" @@ -172,7 +173,7 @@ Nothing -> Just (Var v, True) - sizeForMem mem = maybeHead $ mapMaybe (arrayInMem . paramAttr) val_params + sizeForMem mem = maybeHead $ mapMaybe (arrayInMem . paramDec) val_params where arrayInMem (MemArray pt shape _ (ArrayIn arraymem ixfun)) | IxFun.isDirect ixfun, Just (dims, b) <- @@ -191,7 +192,7 @@ modify $ M.insert (paramName fparam) (bufname, b) return $ BufferAlloc bufname size space b Array {} - | MemArray _ _ _ (ArrayIn mem ixfun) <- paramAttr fparam -> do + | MemArray _ _ _ (ArrayIn mem ixfun) <- paramDec fparam -> do buffered <- gets $ M.lookup mem case buffered of Just (bufname, b) -> do @@ -206,8 +207,8 @@ allocStms merge = runWriterT . zipWithM allocation merge where allocation m@(Param pname _, _) (BufferAlloc name size space b) = do stms <- lift $ runBinder_ $ do - size' <- letSubExp "double_buffer_size" =<< toExp size - letBindNames_ [name] $ Op $ Alloc size' space + size' <- toSubExp "double_buffer_size" size + letBindNames [name] $ Op $ Alloc size' space tell $ stmsToList stms if b then return (Param pname $ MemMem space, Var name) else return m diff --git a/src/Futhark/Optimise/Fusion.hs b/src/Futhark/Optimise/Fusion.hs --- a/src/Futhark/Optimise/Fusion.hs +++ b/src/Futhark/Optimise/Fusion.hs @@ -2,7 +2,10 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} --- | Perform horizontal and vertical fusion of SOACs. +-- | Perform horizontal and vertical fusion of SOACs. See the paper +-- /A T2 Graph-Reduction Approach To Fusion/ for the basic idea (some +-- extensions discussed in /Design and GPGPU Performance of Futhark’s +-- Redomap Construct/). module Futhark.Optimise.Fusion ( fuseSOACs ) where @@ -14,15 +17,15 @@ import qualified Data.Set as S import qualified Data.List as L -import Futhark.Representation.AST.Attributes.Aliases -import Futhark.Representation.SOACS hiding (SOAC(..)) -import qualified Futhark.Representation.Aliases as Aliases -import qualified Futhark.Representation.SOACS as Futhark +import Futhark.IR.Prop.Aliases +import Futhark.IR.SOACS hiding (SOAC(..)) +import qualified Futhark.IR.Aliases as Aliases +import qualified Futhark.IR.SOACS as Futhark import Futhark.MonadFreshNames -import Futhark.Representation.SOACS.Simplify +import Futhark.IR.SOACS.Simplify import Futhark.Optimise.Fusion.LoopKernel import Futhark.Construct -import qualified Futhark.Analysis.HORepresentation.SOAC as SOAC +import qualified Futhark.Analysis.HORep.SOAC as SOAC import qualified Futhark.Analysis.Alias as Alias import Futhark.Transform.Rename import Futhark.Transform.Substitute @@ -32,10 +35,10 @@ | IsNotArray (NameInfo SOACS) varEntryType :: VarEntry -> NameInfo SOACS -varEntryType (IsArray _ attr _ _) = - attr -varEntryType (IsNotArray attr) = - attr +varEntryType (IsArray _ dec _ _) = + dec +varEntryType (IsNotArray dec) = + dec varEntryAliases :: VarEntry -> Names varEntryAliases (IsArray _ _ x _) = x @@ -69,7 +72,7 @@ putNameSource = put instance HasScope SOACS FusionGM where - askScope = toScope <$> asks varsInScope + askScope = asks $ toScope . varsInScope where toScope = M.map varEntryType ------------------------------------------------------------------------ @@ -81,8 +84,8 @@ bindVar env (Ident name t, aliases) = env { varsInScope = M.insert name entry $ varsInScope env } where entry = case t of - Array {} -> IsArray name (LetInfo t) aliases' $ SOAC.identInput $ Ident name t - _ -> IsNotArray $ LetInfo t + Array {} -> IsArray name (LetName t) aliases' $ SOAC.identInput $ Ident name t + _ -> IsNotArray $ LetName t expand = maybe mempty varEntryAliases . flip M.lookup (varsInScope env) aliases' = aliases <> mconcat (map expand $ namesToList aliases) @@ -108,7 +111,7 @@ bindingFamilyVar :: [VName] -> FusionGEnv -> Ident -> FusionGEnv bindingFamilyVar faml env (Ident nm t) = env { soacs = M.insert nm faml $ soacs env - , varsInScope = M.insert nm (IsArray nm (LetInfo t) mempty $ + , varsInScope = M.insert nm (IsArray nm (LetName t) mempty $ SOAC.identInput $ Ident nm t) $ varsInScope env } @@ -146,13 +149,13 @@ Just (IsArray src' _ aliases input) -> env { varsInScope = M.insert vname - (IsArray src' (LetInfo attr) (oneName srcname <> aliases) $ + (IsArray src' (LetName dec) (oneName srcname <> aliases) $ trns `SOAC.addTransform` input) $ varsInScope env } _ -> bindVar env (patElemIdent pe, oneName vname) where vname = patElemName pe - attr = patElemAttr pe + dec = patElemDec pe -- | Binds the fusion result to the environment. bindRes :: FusedRes -> FusionGM a -> FusionGM a @@ -172,6 +175,7 @@ --- and fuse them in a second pass! --- ------------------------------------------------------------------------ +-- | The pass definition. fuseSOACs :: Pass SOACS SOACS fuseSOACs = Pass { passName = "Fuse SOACs" @@ -292,12 +296,12 @@ other_nms <- expandSoacInpArr other_nms0 return (inp_nms, other_nms) -addNewKerWithInfusible :: FusedRes -> ([Ident], Certificates, SOAC, Names) -> Names -> FusionGM FusedRes -addNewKerWithInfusible res (idd, cs, soac, consumed) ufs = do +addNewKerWithInfusible :: FusedRes -> ([Ident], StmAux (), SOAC, Names) -> Names -> FusionGM FusedRes +addNewKerWithInfusible res (idd, aux, soac, consumed) ufs = do nm_ker <- KernName <$> newVName "ker" scope <- askScope let out_nms = map identName idd - new_ker = newKernel cs soac consumed out_nms scope + new_ker = newKernel aux soac consumed out_nms scope comb = M.unionWith S.union os' = M.fromList [(arr,nm_ker) | arr <- out_nms] `M.union` outArr res @@ -332,9 +336,9 @@ -- @orig_soac@ and @out_idds@ the current SOAC and its binding pattern -- @consumed@ is the set of names consumed by the SOAC. -- Output: a new Fusion Result (after processing the current SOAC binding) -greedyFuse :: [Stm] -> Names -> FusedRes -> (Pattern, Certificates, SOAC, Names) +greedyFuse :: [Stm] -> Names -> FusedRes -> (Pattern, StmAux (), SOAC, Names) -> FusionGM FusedRes -greedyFuse rem_bnds lam_used_nms res (out_idds, cs, orig_soac, consumed) = do +greedyFuse rem_bnds lam_used_nms res (out_idds, aux, orig_soac, consumed) = do soac <- inlineSOACInputs orig_soac (inp_nms, other_nms) <- soacInputs soac -- Assumption: the free vars in lambda are already in @infusible res@. @@ -355,8 +359,8 @@ (ok_kers_compat, fused_kers, fused_nms, old_kers, oldker_nms) <- if is_screma || any isInfusible out_nms - then horizontGreedyFuse rem_bnds res (out_idds, cs, soac, consumed) - else prodconsGreedyFuse res (out_idds, cs, soac, consumed) + then horizontGreedyFuse rem_bnds res (out_idds, aux, soac, consumed) + else prodconsGreedyFuse res (out_idds, aux, soac, consumed) -- -- (ii) check whether fusing @soac@ will violate any in-place update -- restriction, e.g., would move an input array past its in-place update. @@ -381,7 +385,7 @@ let comb = M.unionWith S.union if not fusible_ker then - addNewKerWithInfusible res (patternIdents out_idds, cs, soac, consumed) ufs + addNewKerWithInfusible res (patternIdents out_idds, aux, soac, consumed) ufs else do -- Need to suitably update `inpArr': -- (i) first remove the inpArr bindings of the old kernel @@ -414,9 +418,9 @@ -- but make sure NOT to add a new kernel! return $ FusedRes True (outArr res) inpArr'' ufs kernels' -prodconsGreedyFuse :: FusedRes -> (Pattern, Certificates, SOAC, Names) +prodconsGreedyFuse :: FusedRes -> (Pattern, StmAux (), SOAC, Names) -> FusionGM (Bool, [FusedKer], [KernName], [FusedKer], [KernName]) -prodconsGreedyFuse res (out_idds, cs, soac, consumed) = do +prodconsGreedyFuse res (out_idds, aux, soac, consumed) = do let out_nms = patternNames out_idds -- Extract VNames from output patterns to_fuse_knmSet = getKersWithInpArrs res out_nms -- Find kernels which consume outputs to_fuse_knms = S.toList to_fuse_knmSet @@ -434,11 +438,11 @@ Nothing -> return (False, []) Just kers' -> return (True, map certifyKer kers') return (ok_kers_compat, fused_kers, to_fuse_knms, to_fuse_kers, to_fuse_knms) - where certifyKer k = k { certificates = certificates k <> cs } + where certifyKer k = k { kerAux = kerAux k <> aux } -horizontGreedyFuse :: [Stm] -> FusedRes -> (Pattern, Certificates, SOAC, Names) +horizontGreedyFuse :: [Stm] -> FusedRes -> (Pattern, StmAux (), SOAC, Names) -> FusionGM (Bool, [FusedKer], [KernName], [FusedKer], [KernName]) -horizontGreedyFuse rem_bnds res (out_idds, cs, soac, consumed) = do +horizontGreedyFuse rem_bnds res (out_idds, aux, soac, consumed) = do (inp_nms, _) <- soacInputs soac let out_nms = patternNames out_idds infusible_nms = namesFromList $ filter (`nameIn` infusible res) out_nms @@ -470,7 +474,7 @@ scope <- askScope let kernminds' = L.sortBy (\(_,_,i1) (_,_,i2)->compare i1 i2) $ catMaybes kernminds - soac_kernel = newKernel cs soac consumed out_nms scope + soac_kernel = newKernel aux soac consumed out_nms scope -- now try to fuse kernels one by one (in a fold); @ok_ind@ is the index of the -- kernel until which fusion succeded, and @fused_ker@ is the resulting kernel. @@ -522,7 +526,9 @@ (fsoac cur_ker) (fusedConsumed cur_ker) ker case new_ker of Nothing -> return (False, n,bnd_ind,cur_ker,mempty) - Just krn-> return (True,n+1,bnd_ind,krn,new_ufus_nms) + Just krn-> + let krn' = krn { kerAux = aux <> kerAux krn } + in return (True,n+1,bnd_ind,krn',new_ufus_nms) ) (True,0,0,soac_kernel,infusible_nms) kernminds' -- Find the kernels we have fused into and the name of the last such @@ -592,9 +598,9 @@ j <- newVName "j" loop_body <- runBodyBinder $ do forM_ (zip loop_params chunked_params) $ \(p,a_p) -> - letBindNames_ [paramName p] $ BasicOp $ Index (paramName a_p) $ + letBindNames [paramName p] $ BasicOp $ Index (paramName a_p) $ fullSlice (paramType a_p) [DimFix $ Futhark.Var j] - letBindNames_ [i] $ BasicOp $ BinOp (Add it OverflowUndef) (Futhark.Var offset) (Futhark.Var j) + letBindNames [i] $ BasicOp $ BinOp (Add it OverflowUndef) (Futhark.Var offset) (Futhark.Var j) return body eBody [pure $ DoLoop [] merge' (ForLoop j it (Futhark.Var chunk_size) []) loop_body, @@ -656,7 +662,7 @@ bres' <- checkForUpdates bres e foldM fusionGatherExp bres' (e:pat_vars) - where cs = stmCerts bnd + where aux = stmAux bnd rem_bnds = bnd : bnds consumed = consumedInExp $ Alias.analyseExp mempty e @@ -665,13 +671,13 @@ bres <- bindingFamily pat $ fusionGatherStms lres bnds res bres' <- foldM fusionGatherSubExp bres nes consumed' <- varsAliases consumed - greedyFuse rem_bnds used_lam bres' (pat, cs, soac, consumed') + greedyFuse rem_bnds used_lam bres' (pat, aux, soac, consumed') mapLike fres' soac lambda = do bres <- bindingFamily pat $ fusionGatherStms fres' bnds res (used_lam, blres) <- fusionGatherLam (mempty, bres) lambda consumed' <- varsAliases consumed - greedyFuse rem_bnds used_lam blres (pat, cs, soac, consumed') + greedyFuse rem_bnds used_lam blres (pat, aux, soac, consumed') fusionGatherStms fres [] res = foldM fusionGatherExp fres $ map (BasicOp . SubExp) res @@ -745,7 +751,7 @@ -- cannot be fused from outside the lambda: let inp_arrs = namesFromList $ M.keys $ inpArr new_res let unfus = infusible new_res <> inp_arrs - bnds <- M.keys <$> asks varsInScope + bnds <- asks $ M.keys . varsInScope let unfus' = unfus `namesIntersection` namesFromList bnds -- merge fres with new_res' let new_res' = new_res { infusible = unfus' } @@ -817,10 +823,10 @@ throwError $ Error ("In Fusion.hs, replaceSOAC, unfused kernel " ++"still in result: "++pretty names) - insertKerSOAC (outNames ker) ker + insertKerSOAC aux (outNames ker) ker -insertKerSOAC :: [VName] -> FusedKer -> FusionGM (Stms SOACS) -insertKerSOAC names ker = do +insertKerSOAC :: StmAux () -> [VName] -> FusedKer -> FusionGM (Stms SOACS) +insertKerSOAC aux names ker = do new_soac' <- finaliseSOAC $ fsoac ker runBinder_ $ do f_soac <- SOAC.toSOAC new_soac' @@ -828,7 +834,7 @@ -- issue #224). We insert copy expressions to fix it. f_soac' <- copyNewlyConsumed (fusedConsumed ker) $ addOpAliases f_soac validents <- zipWithM newIdent (map baseString names) $ SOAC.typeOf new_soac' - letBind_ (basicPattern [] validents) $ Op f_soac' + auxing (kerAux ker <> aux) $ letBind (basicPattern [] validents) $ Op f_soac' transformOutput (outputTransform ker) names validents -- | Perform simplification and fusion inside the lambda(s) of a SOAC. diff --git a/src/Futhark/Optimise/Fusion/Composing.hs b/src/Futhark/Optimise/Fusion/Composing.hs --- a/src/Futhark/Optimise/Fusion/Composing.hs +++ b/src/Futhark/Optimise/Fusion/Composing.hs @@ -21,9 +21,9 @@ import qualified Data.Map.Strict as M import Data.Maybe -import qualified Futhark.Analysis.HORepresentation.SOAC as SOAC +import qualified Futhark.Analysis.HORep.SOAC as SOAC -import Futhark.Representation.AST +import Futhark.IR import Futhark.Binder (Bindable(..), insertStm, insertStms, mkLet) import Futhark.Construct (mapResult) import Futhark.Util (splitAt3, takeLast, dropLast) @@ -203,7 +203,7 @@ mergeReduceOps :: Lambda lore -> Lambda lore -> Lambda lore mergeReduceOps (Lambda par1 bdy1 rtp1) (Lambda par2 bdy2 rtp2) = - let body' = Body (bodyAttr bdy1) + let body' = Body (bodyDec bdy1) (bodyStms bdy1 <> bodyStms bdy2) (bodyResult bdy1 ++ bodyResult bdy2) (len1, len2) = (length rtp1, length rtp2) diff --git a/src/Futhark/Optimise/Fusion/LoopKernel.hs b/src/Futhark/Optimise/Fusion/LoopKernel.hs --- a/src/Futhark/Optimise/Fusion/LoopKernel.hs +++ b/src/Futhark/Optimise/Fusion/LoopKernel.hs @@ -24,13 +24,13 @@ import Data.Maybe import Data.List (find, (\\), tails) -import Futhark.Representation.SOACS hiding (SOAC(..)) -import qualified Futhark.Representation.SOACS as Futhark +import Futhark.IR.SOACS hiding (SOAC(..)) +import qualified Futhark.IR.SOACS as Futhark import Futhark.Transform.Rename (renameLambda) import Futhark.Transform.Substitute import Futhark.MonadFreshNames -import qualified Futhark.Analysis.HORepresentation.SOAC as SOAC -import qualified Futhark.Analysis.HORepresentation.MapNest as MapNest +import qualified Futhark.Analysis.HORep.SOAC as SOAC +import qualified Futhark.Analysis.HORep.MapNest as MapNest import Futhark.Pass.ExtractKernels.ISRWIM (rwimPossible) import Futhark.Optimise.Fusion.Composing import Futhark.Construct @@ -122,12 +122,11 @@ , outputTransform :: SOAC.ArrayTransforms , outNames :: [VName] - , certificates :: Certificates - } - deriving (Show) + , kerAux :: StmAux () + } deriving (Show) -newKernel :: Certificates -> SOAC -> Names -> [VName] -> Scope SOACS -> FusedKer -newKernel cs soac consumed out_nms scope = +newKernel :: StmAux () -> SOAC -> Names -> [VName] -> Scope SOACS -> FusedKer +newKernel aux soac consumed out_nms scope = FusedKer { fsoac = soac , inplace = consumed , fusedVars = [] @@ -135,7 +134,7 @@ , outputTransform = SOAC.noTransforms , outNames = out_nms , kernelScope = scope - , certificates = cs + , kerAux = aux } arrInputs :: FusedKer -> S.Set VName @@ -352,7 +351,7 @@ c_num_buckets = length ops_c (body_p, body_c) = (lambdaBody lam_p, lambdaBody lam_c) body' = - Body { bodyAttr = bodyAttr body_p -- body_p and body_c have the same lores + Body { bodyDec = bodyDec body_p -- body_p and body_c have the same lores , bodyStms = bodyStms body_p <> bodyStms body_c , bodyResult = take c_num_buckets (bodyResult body_c) ++ take p_num_buckets (bodyResult body_p) ++ @@ -381,7 +380,7 @@ ys_p = take leny ys ys2 = drop leny ys let (body_p, body2) = (lambdaBody lam_p, lambdaBody lam_c) - let body' = Body { bodyAttr = bodyAttr body_p -- body_p and body2 have the same lores + let body' = Body { bodyDec = bodyDec body_p -- body_p and body2 have the same lores , bodyStms = bodyStms body_p <> bodyStms body2 , bodyResult = zipW (bodyResult body_p) (bodyResult body2) } @@ -475,6 +474,10 @@ --------------------------------- _ -> fail "Cannot fuse" +getStreamOrder :: StreamForm lore -> StreamOrd +getStreamOrder (Parallel o _ _ _) = o +getStreamOrder (Sequential _) = InOrder + fuseStreamHelper :: [VName] -> Names -> [VName] -> [(VName,Ident)] -> SOAC -> SOAC -> TryFusion ([VName], SOAC) fuseStreamHelper out_kernms unfus_set outVars outPairs @@ -590,12 +593,12 @@ removeParamOuterDim :: LParam -> LParam removeParamOuterDim param = let t = rowType $ paramType param - in param { paramAttr = t } + in param { paramDec = t } setParamOuterDimTo :: SubExp -> LParam -> LParam setParamOuterDimTo w param = let t = paramType param `setOuterSize` w - in param { paramAttr = t } + in param { paramDec = t } setPatternOuterDimTo :: SubExp -> Pattern -> Pattern setPatternOuterDimTo w = fmap (`setOuterSize` w) diff --git a/src/Futhark/Optimise/InPlaceLowering.hs b/src/Futhark/Optimise/InPlaceLowering.hs --- a/src/Futhark/Optimise/InPlaceLowering.hs +++ b/src/Futhark/Optimise/InPlaceLowering.hs @@ -44,7 +44,7 @@ -- (2) @k@ and @y@ must be available at the beginning of the loop. -- -- (3) @x@ must be visible whenever @r@ is visible. (This means --- that both @x@ and @r@ must be bound in the same 'Body'.) +-- that both @x@ and @r@ must be bound in the same t'Body'.) -- -- (4) If @x@ is consumed at a point after the loop, @r@ must not -- be used after that point. @@ -72,9 +72,9 @@ import qualified Data.Map.Strict as M import Futhark.Analysis.Alias -import Futhark.Representation.Aliases -import Futhark.Representation.Kernels -import Futhark.Representation.Seq (Seq) +import Futhark.IR.Aliases +import Futhark.IR.Kernels +import Futhark.IR.Seq (Seq) import Futhark.Optimise.InPlaceLowering.LowerIntoStm import Futhark.MonadFreshNames import Futhark.Binder @@ -154,15 +154,15 @@ where boundHere = patternNames $ stmPattern bnd - checkIfForwardableUpdate (Let pat (StmAux cs _) e) - | Pattern [] [PatElem v attr] <- pat, + checkIfForwardableUpdate (Let pat (StmAux cs _ _) e) + | Pattern [] [PatElem v dec] <- pat, BasicOp (Update src slice (Var ve)) <- e = - maybeForward ve v attr cs src slice + maybeForward ve v dec cs src slice checkIfForwardableUpdate _ = return () optimiseInStm :: Constraints lore => Stm (Aliases lore) -> ForwardingM lore (Stm (Aliases lore)) -optimiseInStm (Let pat attr e) = - Let pat attr <$> optimiseExp e +optimiseInStm (Let pat dec e) = + Let pat dec <$> optimiseExp e optimiseExp :: Constraints lore => Exp (Aliases lore) -> ForwardingM lore (Exp (Aliases lore)) optimiseExp (DoLoop ctx val form body) = @@ -205,7 +205,7 @@ } data BottomUp lore = BottomUp { bottomUpSeen :: Names - , forwardThese :: [DesiredUpdate (LetAttr (Aliases lore))] + , forwardThese :: [DesiredUpdate (LetDec (Aliases lore))] } instance Semigroup (BottomUp lore) where @@ -239,28 +239,28 @@ , topOnOp = g } -bindingParams :: (attr -> NameInfo (Aliases lore)) - -> [Param attr] +bindingParams :: (dec -> NameInfo (Aliases lore)) + -> [Param dec] -> ForwardingM lore a -> ForwardingM lore a bindingParams f params = local $ \(TopDown n vtable d x y) -> let entry fparam = (paramName fparam, - Entry n mempty d False $ f $ paramAttr fparam) + Entry n mempty d False $ f $ paramDec fparam) entries = M.fromList $ map entry params in TopDown (n+1) (M.union entries vtable) d x y bindingFParams :: [FParam (Aliases lore)] -> ForwardingM lore a -> ForwardingM lore a -bindingFParams = bindingParams FParamInfo +bindingFParams = bindingParams FParamName bindingScope :: Scope (Aliases lore) -> ForwardingM lore a -> ForwardingM lore a bindingScope scope = local $ \(TopDown n vtable d x y) -> let entries = M.map entry scope - infoAliases (LetInfo (aliases, _)) = unNames aliases + infoAliases (LetName (aliases, _)) = unNames aliases infoAliases _ = mempty entry info = Entry n (infoAliases info) d False info in TopDown (n+1) (entries<>vtable) d x y @@ -271,9 +271,9 @@ bindingStm (Let pat _ _) = local $ \(TopDown n vtable d x y) -> let entries = M.fromList $ map entry $ patternElements pat entry patElem = - let (aliases, _) = patElemAttr patElem + let (aliases, _) = patElemDec patElem in (patElemName patElem, - Entry n (unNames aliases) d True $ LetInfo $ patElemAttr patElem) + Entry n (unNames aliases) d True $ LetName $ patElemDec patElem) in TopDown (n+1) (M.union entries vtable) d x y bindingNumber :: VName -> ForwardingM lore Int @@ -320,10 +320,10 @@ maybeForward :: Constraints lore => VName - -> VName -> LetAttr (Aliases lore) + -> VName -> LetDec (Aliases lore) -> Certificates -> VName -> Slice SubExp -> ForwardingM lore () -maybeForward v dest_nm dest_attr cs src slice = do +maybeForward v dest_nm dest_dec cs src slice = do -- Checks condition (2) available <- (freeIn src <> freeIn slice <> freeIn cs) `areAvailableBefore` v @@ -333,5 +333,5 @@ optimisable <- isOptimisable v not_prim <- not . primType <$> lookupType v when (available && samebody && optimisable && not_prim) $ do - let fwd = DesiredUpdate dest_nm dest_attr cs src slice v + let fwd = DesiredUpdate dest_nm dest_dec cs src slice v tell mempty { forwardThese = [fwd] } diff --git a/src/Futhark/Optimise/InPlaceLowering/LowerIntoStm.hs b/src/Futhark/Optimise/InPlaceLowering/LowerIntoStm.hs --- a/src/Futhark/Optimise/InPlaceLowering/LowerIntoStm.hs +++ b/src/Futhark/Optimise/InPlaceLowering/LowerIntoStm.hs @@ -9,20 +9,21 @@ import Control.Monad import Control.Monad.Writer -import Data.List (find) +import Data.List (find, unzip4) import Data.Maybe (mapMaybe) import Data.Either import qualified Data.Map as M -import Futhark.Representation.AST.Attributes.Aliases -import Futhark.Representation.Aliases -import Futhark.Representation.Kernels +import Futhark.Analysis.PrimExp.Convert +import Futhark.IR.Prop.Aliases +import Futhark.IR.Aliases +import Futhark.IR.Kernels import Futhark.Construct import Futhark.Optimise.InPlaceLowering.SubstituteIndices -data DesiredUpdate attr = +data DesiredUpdate dec = DesiredUpdate { updateName :: VName -- ^ Name of result. - , updateType :: attr -- ^ Type of result. + , updateType :: dec -- ^ Type of result. , updateCertificates :: Certificates , updateSource :: VName , updateIndices :: Slice SubExp @@ -33,16 +34,16 @@ instance Functor DesiredUpdate where f `fmap` u = u { updateType = f $ updateType u } -updateHasValue :: VName -> DesiredUpdate attr -> Bool +updateHasValue :: VName -> DesiredUpdate dec -> Bool updateHasValue name = (name==) . updateValue type LowerUpdate lore m = Scope (Aliases lore) -> Stm (Aliases lore) - -> [DesiredUpdate (LetAttr (Aliases lore))] + -> [DesiredUpdate (LetDec (Aliases lore))] -> Maybe (m [Stm (Aliases lore)]) lowerUpdate :: (MonadFreshNames m, Bindable lore, - LetAttr lore ~ Type, CanBeAliased (Op lore)) => LowerUpdate lore m + LetDec lore ~ Type, CanBeAliased (Op lore)) => LowerUpdate lore m lowerUpdate scope (Let pat aux (DoLoop ctx val form body)) updates = do canDo <- lowerUpdateIntoLoop scope updates pat ctx val form body Just $ do @@ -52,68 +53,82 @@ mkLet ctxpat valpat $ DoLoop ctx' val' form body'] ++ postbnds lowerUpdate _ (Let pat aux (BasicOp (SubExp (Var v)))) - [DesiredUpdate bindee_nm bindee_attr cs src is val] + [DesiredUpdate bindee_nm bindee_dec cs src is val] | patternNames pat == [src] = - let is' = fullSlice (typeOf bindee_attr) is + let is' = fullSlice (typeOf bindee_dec) is in Just $ return [certify (stmAuxCerts aux <> cs) $ - mkLet [] [Ident bindee_nm $ typeOf bindee_attr] $ + mkLet [] [Ident bindee_nm $ typeOf bindee_dec] $ BasicOp $ Update v is' $ Var val] lowerUpdate _ _ _ = Nothing lowerUpdateKernels :: MonadFreshNames m => LowerUpdate Kernels m -lowerUpdateKernels _ +lowerUpdateKernels scope (Let pat aux (Op (SegOp (SegMap lvl space ts kbody)))) updates | all ((`elem` patternNames pat) . updateValue) updates = do - (pat', kbody', poststms) <- - lowerUpdatesIntoSegMap pat updates space kbody - let cs = stmAuxCerts aux <> foldMap updateCertificates updates - Just $ return $ - certify cs (Let pat' aux $ Op $ SegOp $ SegMap lvl space ts kbody') : - stmsToList poststms + mk <- lowerUpdatesIntoSegMap scope pat updates space kbody + Just $ do + (pat', kbody', poststms) <- mk + let cs = stmAuxCerts aux <> foldMap updateCertificates updates + return $ + certify cs (Let pat' aux $ Op $ SegOp $ SegMap lvl space ts kbody') : + stmsToList poststms lowerUpdateKernels scope stm updates = lowerUpdate scope stm updates -lowerUpdatesIntoSegMap :: Pattern (Aliases Kernels) - -> [DesiredUpdate (LetAttr (Aliases Kernels))] +lowerUpdatesIntoSegMap :: MonadFreshNames m => + Scope (Aliases Kernels) + -> Pattern (Aliases Kernels) + -> [DesiredUpdate (LetDec (Aliases Kernels))] -> SegSpace -> KernelBody (Aliases Kernels) - -> Maybe (Pattern (Aliases Kernels), - KernelBody (Aliases Kernels), - Stms (Aliases Kernels)) -lowerUpdatesIntoSegMap pat updates kspace kbody = do + -> Maybe (m (Pattern (Aliases Kernels), + KernelBody (Aliases Kernels), + Stms (Aliases Kernels))) +lowerUpdatesIntoSegMap scope pat updates kspace kbody = do -- The updates are all-or-nothing. Being more liberal would require -- changes to the in-place-lowering pass itself. - (pes, krets, poststms) <- - unzip3 <$> zipWithM onRet (patternElements pat) (kernelBodyResult kbody) - return (Pattern [] pes, - kbody { kernelBodyResult = krets }, - mconcat poststms) + mk <- zipWithM onRet (patternElements pat) (kernelBodyResult kbody) + return $ do + (pes, bodystms, krets, poststms) <- unzip4 <$> sequence mk + return (Pattern [] pes, + kbody { kernelBodyStms = kernelBodyStms kbody <> mconcat bodystms + , kernelBodyResult = krets + }, + mconcat poststms) - where (gtids, dims) = unzip $ unSegSpace kspace + where (gtids, _dims) = unzip $ unSegSpace kspace - onRet (PatElem v v_attr) (Returns _ se) - | Just (DesiredUpdate bindee_nm bindee_attr _cs src is _val) <- + onRet (PatElem v v_dec) ret + | Just (DesiredUpdate bindee_nm bindee_dec _cs src slice _val) <- find ((==v) . updateValue) updates = do - guard $ sliceDims is == dims + Returns _ se <- Just ret - let ret = WriteReturns (arrayDims $ snd bindee_attr) src - [(map Var gtids, se)] + Just $ do + let pexp = primExpFromSubExp int32 + (slice', bodystms) <- flip runBinderT scope $ + traverse (toSubExp "index") $ + fixSlice (map (fmap pexp) slice) $ + map (pexp . Var) gtids - return (PatElem bindee_nm bindee_attr, - ret, - oneStm $ mkLet [] [Ident v $ typeOf v_attr] $ - BasicOp $ Index bindee_nm is) + let res_dims = arrayDims $ snd bindee_dec + ret' = WriteReturns res_dims src [(map DimFix slice', se)] + return (PatElem bindee_nm bindee_dec, + bodystms, + ret', + oneStm $ mkLet [] [Ident v $ typeOf v_dec] $ + BasicOp $ Index bindee_nm slice) + onRet pe ret = - return (pe, ret, mempty) + Just $ return (pe, mempty, ret, mempty) lowerUpdateIntoLoop :: (Bindable lore, BinderOps lore, - Aliased lore, LetAttr lore ~ (als, Type), + Aliased lore, LetDec lore ~ (als, Type), MonadFreshNames m) => Scope lore - -> [DesiredUpdate (LetAttr lore)] + -> [DesiredUpdate (LetDec lore)] -> Pattern lore -> [(FParam lore, SubExp)] -> [(FParam lore, SubExp)] @@ -170,7 +185,7 @@ return (prebnds, postbnds, ctxpat, valpat, ctx, val', body') where usedInBody = mconcat $ map expandAliases $ namesToList $ freeIn body <> freeIn form expandAliases v = case M.lookup v scope of - Just (LetInfo attr) -> oneName v <> aliasesOf attr + Just (LetName dec) -> oneName v <> aliasesOf dec _ -> oneName v resmap = zip (bodyResult body) $ patternValueIdents pat @@ -183,7 +198,7 @@ return (origmerge ++ extramerge, prebnds, postbnds) mkMerge summary - | Just (update, mergename, mergeattr) <- relatedUpdate summary = do + | Just (update, mergename, mergedec) <- relatedUpdate summary = do source <- newVName "modified_source" let source_t = snd $ updateType update elmident = Ident @@ -198,7 +213,7 @@ (fullSlice source_t $ updateIndices update)]) return $ Right (Param mergename - (toDecl (typeOf mergeattr) Unique), + (toDecl (typeOf mergedec) Unique), Var source) | otherwise = return $ Left $ mergeParam summary @@ -245,25 +260,25 @@ loopInvariant (Var v) = v `notElem` merge_param_names loopInvariant Constant{} = True -data LoopResultSummary attr = +data LoopResultSummary dec = LoopResultSummary { resultSubExp :: SubExp , inPatternAs :: Ident , mergeParam :: (Param DeclType, SubExp) - , relatedUpdate :: Maybe (DesiredUpdate attr, VName, attr) + , relatedUpdate :: Maybe (DesiredUpdate dec, VName, dec) } deriving (Show) -indexSubstitutions :: [LoopResultSummary attr] - -> IndexSubstitutions attr +indexSubstitutions :: [LoopResultSummary dec] + -> IndexSubstitutions dec indexSubstitutions = mapMaybe getSubstitution where getSubstitution res = do - (DesiredUpdate _ _ cs _ is _, nm, attr) <- relatedUpdate res + (DesiredUpdate _ _ cs _ is _, nm, dec) <- relatedUpdate res let name = paramName $ fst $ mergeParam res - return (name, (cs, nm, attr, is)) + return (name, (cs, nm, dec, is)) manipulateResult :: (Bindable lore, MonadFreshNames m) => - [LoopResultSummary (LetAttr lore)] - -> IndexSubstitutions (LetAttr lore) + [LoopResultSummary (LetDec lore)] + -> IndexSubstitutions (LetDec lore) -> m (Result, Stms lore) manipulateResult summaries substs = do let (orig_ses,updated_ses) = partitionEithers $ map unchangedRes summaries @@ -277,8 +292,8 @@ substRes (Var res_v) (subst_v, (_, nm, _, _)) | res_v == subst_v = return $ Var nm - substRes res_se (_, (cs, nm, attr, is)) = do - v' <- newIdent' (++"_updated") $ Ident nm $ typeOf attr + substRes res_se (_, (cs, nm, dec, is)) = do + v' <- newIdent' (++"_updated") $ Ident nm $ typeOf dec tell [certify cs $ mkLet [] [v'] $ BasicOp $ - Update nm (fullSlice (typeOf attr) is) res_se] + Update nm (fullSlice (typeOf dec) is) res_se] return $ Var $ identName v' diff --git a/src/Futhark/Optimise/InPlaceLowering/SubstituteIndices.hs b/src/Futhark/Optimise/InPlaceLowering/SubstituteIndices.hs --- a/src/Futhark/Optimise/InPlaceLowering/SubstituteIndices.hs +++ b/src/Futhark/Optimise/InPlaceLowering/SubstituteIndices.hs @@ -14,48 +14,49 @@ import Control.Monad import qualified Data.Map.Strict as M -import Futhark.Representation.AST.Attributes.Aliases -import Futhark.Representation.AST +import Futhark.IR.Prop.Aliases +import Futhark.IR import Futhark.Construct import Futhark.Util -type IndexSubstitution attr = (Certificates, VName, attr, Slice SubExp) -type IndexSubstitutions attr = [(VName, IndexSubstitution attr)] +type IndexSubstitution dec = (Certificates, VName, dec, Slice SubExp) +type IndexSubstitutions dec = [(VName, IndexSubstitution dec)] -typeEnvFromSubstitutions :: LetAttr lore ~ attr => - IndexSubstitutions attr -> Scope lore +typeEnvFromSubstitutions :: LetDec lore ~ dec => + IndexSubstitutions dec -> Scope lore typeEnvFromSubstitutions = M.fromList . map (fromSubstitution . snd) where fromSubstitution (_, name, t, _) = - (name, LetInfo t) + (name, LetName t) +-- | Perform the substitution. substituteIndices :: (MonadFreshNames m, BinderOps lore, Bindable lore, - Aliased lore, LetAttr lore ~ attr) => - IndexSubstitutions attr -> Stms lore - -> m (IndexSubstitutions attr, Stms lore) + Aliased lore, LetDec lore ~ dec) => + IndexSubstitutions dec -> Stms lore + -> m (IndexSubstitutions dec, Stms lore) substituteIndices substs bnds = runBinderT (substituteIndicesInStms substs bnds) types where types = typeEnvFromSubstitutions substs substituteIndicesInStms :: (MonadBinder m, Bindable (Lore m), Aliased (Lore m)) => - IndexSubstitutions (LetAttr (Lore m)) + IndexSubstitutions (LetDec (Lore m)) -> Stms (Lore m) - -> m (IndexSubstitutions (LetAttr (Lore m))) + -> m (IndexSubstitutions (LetDec (Lore m))) substituteIndicesInStms = foldM substituteIndicesInStm substituteIndicesInStm :: (MonadBinder m, Bindable (Lore m), Aliased (Lore m)) => - IndexSubstitutions (LetAttr (Lore m)) + IndexSubstitutions (LetDec (Lore m)) -> Stm (Lore m) - -> m (IndexSubstitutions (LetAttr (Lore m))) + -> m (IndexSubstitutions (LetDec (Lore m))) substituteIndicesInStm substs (Let pat lore e) = do e' <- substituteIndicesInExp substs e (substs', pat') <- substituteIndicesInPattern substs pat addStm $ Let pat' lore e' return substs' -substituteIndicesInPattern :: (MonadBinder m, LetAttr (Lore m) ~ attr) => - IndexSubstitutions (LetAttr (Lore m)) - -> PatternT attr - -> m (IndexSubstitutions (LetAttr (Lore m)), PatternT attr) +substituteIndicesInPattern :: (MonadBinder m, LetDec (Lore m) ~ dec) => + IndexSubstitutions (LetDec (Lore m)) + -> PatternT dec + -> m (IndexSubstitutions (LetDec (Lore m)), PatternT dec) substituteIndicesInPattern substs pat = do (substs', context) <- mapAccumLM sub substs $ patternContextElements pat (substs'', values) <- mapAccumLM sub substs' $ patternValueElements pat @@ -63,8 +64,8 @@ where sub substs' patElem = return (substs', patElem) substituteIndicesInExp :: (MonadBinder m, Bindable (Lore m), Aliased (Lore m), - LetAttr (Lore m) ~ attr) => - IndexSubstitutions (LetAttr (Lore m)) + LetDec (Lore m) ~ dec) => + IndexSubstitutions (LetDec (Lore m)) -> Exp (Lore m) -> m (Exp (Lore m)) substituteIndicesInExp substs e = do @@ -77,16 +78,16 @@ mapExpM substitute e where copyAnyConsumed = let consumingSubst substs' v - | Just (cs2, src2, src2attr, is2) <- lookup v substs = do + | Just (cs2, src2, src2dec, is2) <- lookup v substs = do row <- certifying cs2 $ letExp (baseString v ++ "_row") $ - BasicOp $ Index src2 $ fullSlice (typeOf src2attr) is2 + BasicOp $ Index src2 $ fullSlice (typeOf src2dec) is2 row_copy <- letExp (baseString v ++ "_row_copy") $ BasicOp $ Copy row return $ update v v (mempty, row_copy, - src2attr `setType` - (typeOf src2attr `setArrayDims` + src2dec `setType` + (typeOf src2dec `setArrayDims` sliceDims is2), []) substs' consumingSubst substs' _ = @@ -94,7 +95,7 @@ in foldM consumingSubst substs . namesToList . consumedInExp substituteIndicesInSubExp :: MonadBinder m => - IndexSubstitutions (LetAttr (Lore m)) + IndexSubstitutions (LetDec (Lore m)) -> SubExp -> m SubExp substituteIndicesInSubExp substs (Var v) = @@ -103,21 +104,21 @@ return se substituteIndicesInVar :: MonadBinder m => - IndexSubstitutions (LetAttr (Lore m)) + IndexSubstitutions (LetDec (Lore m)) -> VName -> m VName substituteIndicesInVar substs v | Just (cs2, src2, _, []) <- lookup v substs = certifying cs2 $ letExp (baseString src2) $ BasicOp $ SubExp $ Var src2 - | Just (cs2, src2, src2_attr, is2) <- lookup v substs = + | Just (cs2, src2, src2_dec, is2) <- lookup v substs = certifying cs2 $ - letExp "idx" $ BasicOp $ Index src2 $ fullSlice (typeOf src2_attr) is2 + letExp "idx" $ BasicOp $ Index src2 $ fullSlice (typeOf src2_dec) is2 | otherwise = return v substituteIndicesInBody :: (MonadBinder m, Bindable (Lore m), Aliased (Lore m)) => - IndexSubstitutions (LetAttr (Lore m)) + IndexSubstitutions (LetDec (Lore m)) -> Body (Lore m) -> m (Body (Lore m)) substituteIndicesInBody substs (Body _ stms res) = do @@ -127,8 +128,8 @@ collectStms $ mapM (substituteIndicesInSubExp substs') res mkBodyM (stms'<>res_stms) res' -update :: VName -> VName -> IndexSubstitution attr -> IndexSubstitutions attr - -> IndexSubstitutions attr +update :: VName -> VName -> IndexSubstitution dec -> IndexSubstitutions dec + -> IndexSubstitutions dec update needle name subst ((othername, othersubst) : substs) | needle == othername = (name, subst) : substs | otherwise = (othername, othersubst) : update needle name subst substs diff --git a/src/Futhark/Optimise/InliningDeadFun.hs b/src/Futhark/Optimise/InliningDeadFun.hs --- a/src/Futhark/Optimise/InliningDeadFun.hs +++ b/src/Futhark/Optimise/InliningDeadFun.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} -- | This module implements a compiler pass for inlining functions, -- then removing those that have become dead. module Futhark.Optimise.InliningDeadFun @@ -10,14 +11,13 @@ import Control.Monad.Identity import Control.Monad.State import Data.List (partition) -import Data.Loc import Data.Maybe import qualified Data.Map.Strict as M import qualified Data.Set as S import Control.Parallel.Strategies -import Futhark.Representation.SOACS -import Futhark.Representation.SOACS.Simplify +import Futhark.IR.SOACS +import Futhark.IR.SOACS.Simplify (simpleSOACS, simplifyFun, simplifyConsts) import Futhark.Optimise.CSE import Futhark.Optimise.Simplify.Lore (addScopeWisdom) @@ -36,18 +36,16 @@ (bs, srcs) = unzip $ parMap rpar f' as in (bs, mconcat srcs) -aggInlineFunctions :: MonadFreshNames m => - CallGraph - -> (Stms SOACS, [FunDef SOACS]) - -> m (Stms SOACS, [FunDef SOACS]) -aggInlineFunctions cg = - fmap (fmap (filter keep)) . recurse 0 . addVtable +aggInlineFunctions :: MonadFreshNames m => Prog SOACS -> m (Prog SOACS) +aggInlineFunctions prog = + let Prog consts funs = prog + in uncurry Prog . fmap (filter keep) <$> + recurse 0 (ST.fromScope (addScopeWisdom (scopeOf consts)), consts, funs) where fdmap fds = M.fromList $ zip (map funDefName fds) fds - addVtable (consts, funs) = - (ST.fromScope (addScopeWisdom (scopeOf consts)), - consts, funs) + cg = buildCallGraph prog + noninlined = findNoninlined prog noCallsTo which fundec = not $ any (`S.member` which) $ allCalledBy (funDefName fundec) cg @@ -72,39 +70,34 @@ partition (noCallsTo (S.fromList $ map funDefName to_be_inlined)) maybe_inline_in - (not_actually_inlined, to_be_inlined') = - partition keep to_be_inlined + keep_although_inlined = filter keep to_be_inlined if null to_be_inlined then return (consts, funs) else do (vtable', consts') <- - if any ((`calledByConsts` cg) . funDefName) to_be_inlined' - then simplifyConsts =<< - performCSEOnStms True <$> - inlineInStms (fdmap to_be_inlined') consts + if any ((`calledByConsts` cg) . funDefName) to_be_inlined + then simplifyConsts . performCSEOnStms True =<< + inlineInStms (fdmap to_be_inlined) consts else pure (vtable, consts) let simplifyFun' fd | i `rem` simplifyRate == 0 = - copyPropagateInFun simpleSOACS vtable' =<< - performCSEOnFunDef True <$> + copyPropagateInFun simpleSOACS vtable' . + performCSEOnFunDef True =<< simplifyFun vtable' fd | otherwise = copyPropagateInFun simpleSOACS vtable' fd let onFun = simplifyFun' <=< - inlineInFunDef (fdmap to_be_inlined') + inlineInFunDef (fdmap to_be_inlined) to_inline_in' <- parMapM onFun to_inline_in - fmap (not_actually_inlined<>) <$> + fmap (keep_although_inlined<>) <$> recurse (i+1) (vtable', consts', not_to_inline_in <> to_inline_in') keep fd = - isJust (funDefEntryPoint fd) || callsRecursive fd - - callsRecursive fd = any recursive $ allCalledBy (funDefName fd) cg - recursive fname = calls fname fname cg + isJust (funDefEntryPoint fd) || funDefName fd `S.member` noninlined -- | @inlineInFunDef constf fdmap caller@ inlines in @calleer@ the -- functions in @fdmap@ that are called as @constf@. At this point the @@ -119,7 +112,7 @@ inlineFunction :: MonadFreshNames m => Pattern - -> StmAux attr + -> StmAux dec -> [(SubExp, Diet)] -> (Safety, SrcLoc, [SrcLoc]) -> FunDef SOACS @@ -143,7 +136,7 @@ body_stms = stmsToList $ - addLocations safety (filter notNoLoc (loc:locs)) $ + addLocations (stmAuxAttrs aux) safety (filter notmempty (loc:locs)) $ bodyStms $ funDefBody fun reshapeIfNecessary dim_names ident se @@ -154,7 +147,7 @@ | otherwise = mkLet [] [ident] $ BasicOp $ SubExp se - notNoLoc = (/=NoLoc) . locOf + notmempty = (/=mempty) . locOf inlineInStms :: MonadFreshNames m => M.Map Name (FunDef SOACS) -> Stms SOACS -> m (Stms SOACS) @@ -165,16 +158,18 @@ M.Map Name (FunDef SOACS) -> Body -> m Body inlineInBody fdmap = onBody where inline (Let pat aux (Apply fname args _ what) : rest) - | Just fd <- M.lookup fname fdmap = + | Just fd <- M.lookup fname fdmap, + not noinline = (<>) <$> inlineFunction pat aux args what fd <*> inline rest + where noinline = "noinline" `inAttrs` stmAuxAttrs aux inline (stm : rest) = (:) <$> onStm stm <*> inline rest inline [] = pure mempty - onBody (Body attr stms res) = - Body attr . stmsFromList <$> inline (stmsToList stms) <*> pure res + onBody (Body dec stms res) = + Body dec . stmsFromList <$> inline (stmsToList stms) <*> pure res onStm (Let pat aux e) = Let pat aux <$> mapExpM inliner e @@ -191,36 +186,46 @@ onLambda (Lambda params body ret) = Lambda params <$> onBody body <*> pure ret -addLocations :: Safety -> [SrcLoc] -> Stms SOACS -> Stms SOACS -addLocations caller_safety more_locs = fmap onStm - where onStm stm = stm { stmExp = onExp $ stmExp stm } - onExp (Apply fname args t (safety, loc,locs)) = +-- Propagate source locations and attributes to the inlined +-- statements. Attributes are propagated only when applicable (this +-- probably means that every supported attribute needs to be handled +-- specially here). +addLocations :: Attrs -> Safety -> [SrcLoc] -> Stms SOACS -> Stms SOACS +addLocations attrs caller_safety more_locs = fmap onStm + where onStm (Let pat aux (Apply fname args t (safety, loc,locs))) = + Let pat aux' $ Apply fname args t (min caller_safety safety, loc,locs++more_locs) - onExp (BasicOp (Assert cond desc (loc,locs))) = + where aux' = aux { stmAuxAttrs = attrs <> stmAuxAttrs aux } + onStm (Let pat aux (BasicOp (Assert cond desc (loc,locs)))) = + Let pat aux $ case caller_safety of Safe -> BasicOp $ Assert cond desc (loc,locs++more_locs) Unsafe -> BasicOp $ SubExp $ Constant Checked - onExp (Op soac) = Op $ runIdentity $ mapSOACM - identitySOACMapper { mapOnSOACLambda = return . onLambda - } soac - onExp e = mapExp identityMapper { mapOnBody = const $ return . onBody - } e - onBody body = - body { bodyStms = addLocations caller_safety more_locs $ bodyStms body } - onLambda :: Lambda -> Lambda - onLambda lam = lam { lambdaBody = onBody $ lambdaBody lam } + onStm (Let pat aux (Op soac)) = + Let pat (withAttrs aux) $ Op $ runIdentity $ mapSOACM + identitySOACMapper { mapOnSOACLambda = return . onLambda + } soac + where onLambda lam = + lam { lambdaBody = onBody mempty $ lambdaBody lam } + onStm (Let pat aux e) = + Let pat aux $ onExp e --- | Inline 'NotConstFun' functions and remove the resulting dead functions. + onExp = mapExp identityMapper + { mapOnBody = const $ return . onBody attrs } + + withAttrs aux = aux { stmAuxAttrs = attrs <> stmAuxAttrs aux } + + onBody attrs' body = + body { bodyStms = addLocations attrs' caller_safety more_locs $ + bodyStms body } + +-- | Inline all functions and remove the resulting dead functions. inlineFunctions :: Pass SOACS SOACS inlineFunctions = Pass { passName = "Inline functions" , passDescription = "Inline and remove resulting dead functions." - , passFunction = pass + , passFunction = copyPropagateInProg simpleSOACS <=< aggInlineFunctions } - where pass prog@(Prog consts funs) = do - let cg = buildCallGraph prog - (consts', funs') <- aggInlineFunctions cg (consts, funs) - copyPropagateInProg simpleSOACS $ Prog consts' funs' -- | @removeDeadFunctions prog@ removes the functions that are unreachable from -- the main function from the program. diff --git a/src/Futhark/Optimise/Simplify.hs b/src/Futhark/Optimise/Simplify.hs --- a/src/Futhark/Optimise/Simplify.hs +++ b/src/Futhark/Optimise/Simplify.hs @@ -2,7 +2,6 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE Strict #-} -{-# LANGUAGE StrictData #-} module Futhark.Optimise.Simplify ( simplifyProg , simplifySomething @@ -23,7 +22,7 @@ where import Data.Bifunctor (second) -import Futhark.Representation.AST +import Futhark.IR import Futhark.MonadFreshNames import qualified Futhark.Optimise.Simplify.Engine as Engine import qualified Futhark.Analysis.SymbolTable as ST @@ -99,7 +98,7 @@ -> m (FunDef lore) simplifyFun = simplifySomething Engine.simplifyFun removeFunDefWisdom --- | Simplify just a single 'Lambda'. +-- | Simplify just a single t'Lambda'. simplifyLambda :: (MonadFreshNames m, HasScope lore m, Engine.SimplifiableLore lore) => Engine.SimpleOps lore diff --git a/src/Futhark/Optimise/Simplify/ClosedForm.hs b/src/Futhark/Optimise/Simplify/ClosedForm.hs --- a/src/Futhark/Optimise/Simplify/ClosedForm.hs +++ b/src/Futhark/Optimise/Simplify/ClosedForm.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Safe #-} -- | This module implements facilities for determining whether a -- reduction or fold can be expressed in a closed form (i.e. not as a -- SOAC). @@ -18,7 +19,7 @@ import qualified Data.Map.Strict as M import Futhark.Construct -import Futhark.Representation.AST +import Futhark.IR import Futhark.Transform.Rename import Futhark.Optimise.Simplify.Rule @@ -41,7 +42,7 @@ -- | @foldClosedForm look foldfun accargs arrargs@ determines whether -- each of the results of @foldfun@ can be expressed in a closed form. -foldClosedForm :: (Attributes lore, BinderOps lore) => +foldClosedForm :: (ASTLore lore, BinderOps lore) => VarLookup lore -> Pattern lore -> Lambda lore @@ -58,17 +59,17 @@ (map paramName (lambdaParams lam)) (lambdaBody lam) accs isEmpty <- newVName "fold_input_is_empty" - letBindNames_ [isEmpty] $ + letBindNames [isEmpty] $ BasicOp $ CmpOp (CmpEq int32) inputsize (intConst Int32 0) - letBind_ pat =<< (If (Var isEmpty) + letBind pat =<< (If (Var isEmpty) <$> resultBodyM accs <*> renameBody closedBody - <*> pure (IfAttr [primBodyType t] IfNormal)) + <*> pure (IfDec [primBodyType t] IfNormal)) where knownBnds = determineKnownBindings look lam accs arrs -- | @loopClosedForm pat respat merge bound bodys@ determines whether -- the do-loop can be expressed in a closed form. -loopClosedForm :: (Attributes lore, BinderOps lore) => +loopClosedForm :: (ASTLore lore, BinderOps lore) => Pattern lore -> [(FParam lore,SubExp)] -> Names -> SubExp -> Body lore @@ -80,13 +81,13 @@ closedBody <- checkResults mergenames bound i knownBnds (map identName mergeidents) body mergeexp isEmpty <- newVName "bound_is_zero" - letBindNames_ [isEmpty] $ + letBindNames [isEmpty] $ BasicOp $ CmpOp (CmpSlt Int32) bound (intConst Int32 0) - letBind_ pat =<< (If (Var isEmpty) + letBind pat =<< (If (Var isEmpty) <$> resultBodyM mergeexp <*> renameBody closedBody - <*> pure (IfAttr [primBodyType t] IfNormal)) + <*> pure (IfDec [primBodyType t] IfNormal)) where (mergepat, mergeexp) = unzip merge mergeidents = map paramIdent mergepat mergenames = map paramName mergepat @@ -126,15 +127,15 @@ case bop of LogAnd -> - letBindNames_ [p] $ BasicOp $ BinOp LogAnd this el + letBindNames [p] $ BasicOp $ BinOp LogAnd this el Add t w | Just properly_typed_size <- properIntSize t -> do size' <- properly_typed_size - letBindNames_ [p] =<< + letBindNames [p] =<< eBinOp (Add t w) (eSubExp this) (pure $ BasicOp $ BinOp (Mul t w) el size') FAdd t | Just properly_typed_size <- properFloatSize t -> do size' <- properly_typed_size - letBindNames_ [p] =<< + letBindNames [p] =<< eBinOp (FAdd t) (eSubExp this) (pure $ BasicOp $ BinOp (FMul t) el size') _ -> cannotSimplify -- Um... sorry. diff --git a/src/Futhark/Optimise/Simplify/Engine.hs b/src/Futhark/Optimise/Simplify/Engine.hs --- a/src/Futhark/Optimise/Simplify/Engine.hs +++ b/src/Futhark/Optimise/Simplify/Engine.hs @@ -3,7 +3,6 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE Strict #-} -{-# LANGUAGE StrictData #-} -- | -- -- Perform general rule-based simplification based on data dependency @@ -52,7 +51,6 @@ , simplifyFun , simplifyLambda , simplifyLambdaNoHoisting - , simplifyParam , bindLParams , simplifyBody , SimplifiedBody @@ -71,12 +69,11 @@ import Data.List (find, foldl', nub, mapAccumL) import Data.Maybe -import Futhark.Representation.AST -import Futhark.Representation.AST.Attributes.Aliases +import Futhark.IR +import Futhark.IR.Prop.Aliases import Futhark.Optimise.Simplify.Rule import qualified Futhark.Analysis.SymbolTable as ST import qualified Futhark.Analysis.UsageTable as UT -import Futhark.Analysis.Usage import Futhark.Construct import Futhark.Optimise.Simplify.Lore import Futhark.Util (splitFromEnd) @@ -116,15 +113,12 @@ type Protect m = SubExp -> Pattern (Lore m) -> Op (Lore m) -> Maybe (m ()) data SimpleOps lore = - SimpleOps { mkExpAttrS :: ST.SymbolTable (Wise lore) + SimpleOps { mkExpDecS :: ST.SymbolTable (Wise lore) -> Pattern (Wise lore) -> Exp (Wise lore) - -> SimpleM lore (ExpAttr (Wise lore)) + -> SimpleM lore (ExpDec (Wise lore)) , mkBodyS :: ST.SymbolTable (Wise lore) -> Stms (Wise lore) -> Result -> SimpleM lore (Body (Wise lore)) - , mkLetNamesS :: ST.SymbolTable (Wise lore) - -> [VName] -> Exp (Wise lore) - -> SimpleM lore (Stm (Wise lore), Stms (Wise lore)) , protectHoistedOpS :: Protect (Binder (Wise lore)) -- ^ Make a hoisted Op safe. The SubExp is a boolean -- that is true when the value of the statement will @@ -136,10 +130,9 @@ bindableSimpleOps :: (SimplifiableLore lore, Bindable lore) => SimplifyOp lore (Op lore) -> SimpleOps lore -bindableSimpleOps = SimpleOps mkExpAttrS' mkBodyS' mkLetNamesS' protectHoistedOpS' - where mkExpAttrS' _ pat e = return $ mkExpAttr pat e +bindableSimpleOps = SimpleOps mkExpDecS' mkBodyS' protectHoistedOpS' + where mkExpDecS' _ pat e = return $ mkExpDec pat e mkBodyS' _ bnds res = return $ mkBody bnds res - mkLetNamesS' _ name e = (,) <$> mkLetNames name e <*> pure mempty protectHoistedOpS' _ _ _ = Nothing newtype SimpleM lore a = @@ -288,28 +281,28 @@ Protect m -> (Exp (Lore m) -> Bool) -> SubExp -> Stm (Lore m) -> m () -protectIf _ _ taken (Let pat (StmAux cs _) - (If cond taken_body untaken_body (IfAttr if_ts IfFallback))) = do +protectIf _ _ taken (Let pat aux + (If cond taken_body untaken_body (IfDec if_ts IfFallback))) = do cond' <- letSubExp "protect_cond_conj" $ BasicOp $ BinOp LogAnd taken cond - certifying cs $ - letBind_ pat $ If cond' taken_body untaken_body $ - IfAttr if_ts IfFallback -protectIf _ _ taken (Let pat (StmAux cs _) (BasicOp (Assert cond msg loc))) = do + auxing aux $ + letBind pat $ If cond' taken_body untaken_body $ + IfDec if_ts IfFallback +protectIf _ _ taken (Let pat aux (BasicOp (Assert cond msg loc))) = do not_taken <- letSubExp "loop_not_taken" $ BasicOp $ UnOp Not taken cond' <- letSubExp "protect_assert_disj" $ BasicOp $ BinOp LogOr not_taken cond - certifying cs $ letBind_ pat $ BasicOp $ Assert cond' msg loc -protectIf protect _ taken (Let pat (StmAux cs _) (Op op)) + auxing aux $ letBind pat $ BasicOp $ Assert cond' msg loc +protectIf protect _ taken (Let pat aux (Op op)) | Just m <- protect taken pat op = - certifying cs m -protectIf _ f taken (Let pat (StmAux cs _) e) + auxing aux m +protectIf _ f taken (Let pat aux e) | f e = do taken_body <- eBody [pure e] untaken_body <- eBody $ map (emptyOfType $ patternContextNames pat) (patternValueTypes pat) if_ts <- expTypesFromPattern pat - certifying cs $ - letBind_ pat $ If taken taken_body untaken_body $ - IfAttr if_ts IfFallback + auxing aux $ + letBind pat $ If taken taken_body untaken_body $ + IfDec if_ts IfFallback protectIf _ _ _ stm = addStm stm @@ -327,7 +320,7 @@ -- | Statements that are not worth hoisting out of loops, because they -- are unsafe, and added safety (by 'protectLoopHoisted') may inhibit -- further optimisation.. -notWorthHoisting :: Attributes lore => BlockPred lore +notWorthHoisting :: ASTLore lore => BlockPred lore notWorthHoisting _ _ (Let pat _ e) = not (safeExp e) && any ((>0) . arrayRank) (patternTypes pat) @@ -371,7 +364,7 @@ (uses'',stms') <- simplifyStmsBottomUp' vtable' uses' optimstms return (uses'', stms'++stms) -blockUnhoistedDeps :: Attributes lore => +blockUnhoistedDeps :: ASTLore lore => [Either (Stm lore) (Stm lore)] -> [Either (Stm lore) (Stm lore)] blockUnhoistedDeps = snd . mapAccumL block mempty @@ -386,10 +379,10 @@ provides :: Stm lore -> [VName] provides = patternNames . stmPattern -expandUsage :: (Attributes lore, Aliased lore) => +expandUsage :: (ASTLore lore, Aliased lore) => ST.SymbolTable lore -> UT.UsageTable -> Stm lore -> UT.UsageTable expandUsage vtable utable bnd = - UT.expand (`ST.lookupAliases` vtable) (usageInStm bnd <> usageThroughAliases) <> + UT.expand (`ST.lookupAliases` vtable) (UT.usageInStm bnd <> usageThroughAliases) <> utable where pat = stmPattern bnd usageThroughAliases = @@ -442,10 +435,10 @@ (blocked, hoisted) <- hoistStms rules block vtable usages stms return ((blocked, x), hoisted) -hasFree :: Attributes lore => Names -> BlockPred lore +hasFree :: ASTLore lore => Names -> BlockPred lore hasFree ks _ _ need = ks `namesIntersect` freeIn need -isNotSafe :: Attributes lore => BlockPred lore +isNotSafe :: ASTLore lore => BlockPred lore isNotSafe _ _ = not . safeExp . stmExp isInPlaceBound :: BlockPred m @@ -453,13 +446,13 @@ where isUpdate (BasicOp Update{}) = True isUpdate _ = False -isNotCheap :: Attributes lore => BlockPred lore +isNotCheap :: ASTLore lore => BlockPred lore isNotCheap _ _ = not . cheapStm -cheapStm :: Attributes lore => Stm lore -> Bool +cheapStm :: ASTLore lore => Stm lore -> Bool cheapStm = cheapExp . stmExp -cheapExp :: Attributes lore => Exp lore -> Bool +cheapExp :: ASTLore lore => Exp lore -> Bool cheapExp (BasicOp BinOp{}) = True cheapExp (BasicOp SubExp{}) = True cheapExp (BasicOp UnOp{}) = True @@ -476,7 +469,7 @@ stmIs :: (Stm lore -> Bool) -> BlockPred lore stmIs f _ _ = f -loopInvariantStm :: Attributes lore => ST.SymbolTable lore -> Stm lore -> Bool +loopInvariantStm :: ASTLore lore => ST.SymbolTable lore -> Stm lore -> Bool loopInvariantStm vtable = all (`nameIn` ST.availableAtClosestLoop vtable) . namesToList . freeIn @@ -549,7 +542,7 @@ else transClosSizes all_bnds new_nms (new_bnds ++ hoist_bnds) hasPatName nms bnd = any (`nameIn` nms) $ patternNames $ stmPattern bnd --- | Simplify a single 'Body'. The @[Diet]@ only covers the value +-- | Simplify a single body. The @[Diet]@ only covers the value -- elements, because the context cannot be consumed. simplifyBody :: SimplifiableLore lore => [Diet] -> Body lore -> SimpleM lore (SimplifiedBody lore Result) @@ -598,13 +591,13 @@ simplifyStms stms m = case stmsHead stms of Nothing -> inspectStms mempty m - Just (Let pat (StmAux stm_cs attr) e, stms') -> do + Just (Let pat (StmAux stm_cs attrs dec) e, stms') -> do stm_cs' <- simplify stm_cs ((e', e_stms), e_cs) <- collectCerts $ simplifyExp e (pat', pat_cs) <- collectCerts $ simplifyPattern pat let cs = stm_cs'<>e_cs<>pat_cs inspectStms e_stms $ - inspectStm (mkWiseLetStm pat' (StmAux cs attr) e') $ + inspectStm (mkWiseLetStm pat' (StmAux cs attrs dec) e') $ simplifyStms stms' m inspectStm :: SimplifiableLore lore => @@ -635,7 +628,7 @@ simplifyExp :: SimplifiableLore lore => Exp lore -> SimpleM lore (Exp (Wise lore), Stms (Wise lore)) -simplifyExp (If cond tbranch fbranch (IfAttr ts ifsort)) = do +simplifyExp (If cond tbranch fbranch (IfDec ts ifsort)) = do -- Here, we have to check whether 'cond' puts a bound on some free -- variable, and if so, chomp it. We should also try to do CSE -- across branches. @@ -650,14 +643,14 @@ tbranch' <- localVtable (ST.updateBounds True cond) $ simplifyBody ds tbranch fbranch' <- localVtable (ST.updateBounds False cond) $ simplifyBody ds fbranch (tbranch'',fbranch'', hoisted) <- hoistCommon cond' ifsort tbranch' fbranch' - return (If cond' tbranch'' fbranch'' $ IfAttr ts' ifsort, hoisted) + return (If cond' tbranch'' fbranch'' $ IfDec ts' ifsort, hoisted) simplifyExp (DoLoop ctx val form loopbody) = do let (ctxparams, ctxinit) = unzip ctx (valparams, valinit) = unzip val - ctxparams' <- mapM (simplifyParam simplify) ctxparams + ctxparams' <- mapM (traverse simplify) ctxparams ctxinit' <- mapM simplify ctxinit - valparams' <- mapM (simplifyParam simplify) valparams + valparams' <- mapM (traverse simplify) valparams valinit' <- mapM simplify valinit let ctx' = zip ctxparams' ctxinit' val' = zip valparams' valinit' @@ -666,7 +659,7 @@ ForLoop loopvar it boundexp loopvars -> do boundexp' <- simplify boundexp let (loop_params, loop_arrs) = unzip loopvars - loop_params' <- mapM (simplifyParam simplify) loop_params + loop_params' <- mapM (traverse simplify) loop_params loop_arrs' <- mapM simplify loop_arrs let form' = ForLoop loopvar it boundexp' (zip loop_params' loop_arrs') return (form', @@ -734,10 +727,10 @@ error "Unhandled Op in simplification engine." } -type SimplifiableLore lore = (Attributes lore, - Simplifiable (LetAttr lore), - Simplifiable (FParamAttr lore), - Simplifiable (LParamAttr lore), +type SimplifiableLore lore = (ASTLore lore, + Simplifiable (LetDec lore), + Simplifiable (FParamInfo lore), + Simplifiable (LParamInfo lore), Simplifiable (RetType lore), Simplifiable (BranchType lore), CanBeWise (Op lore), @@ -780,19 +773,15 @@ simplify (Constant v) = return $ Constant v -simplifyPattern :: (SimplifiableLore lore, Simplifiable attr) => - PatternT attr - -> SimpleM lore (PatternT attr) +simplifyPattern :: (SimplifiableLore lore, Simplifiable dec) => + PatternT dec + -> SimpleM lore (PatternT dec) simplifyPattern pat = Pattern <$> mapM inspect (patternContextElements pat) <*> mapM inspect (patternValueElements pat) where inspect (PatElem name lore) = PatElem name <$> simplify lore -simplifyParam :: (attr -> SimpleM lore attr) -> Param attr -> SimpleM lore (Param attr) -simplifyParam simplifyAttribute (Param name attr) = - Param name <$> simplifyAttribute attr - instance Simplifiable () where simplify = pure @@ -849,7 +838,7 @@ -> [Maybe VName] -> SimpleM lore (Lambda (Wise lore), Stms (Wise lore)) simplifyLambdaMaybeHoist blocked lam@(Lambda params body rettype) arrs = do - params' <- mapM (simplifyParam simplify) params + params' <- mapM (traverse simplify) params let (nonarrayparams, arrayparams) = splitAt (length params' - length arrs) params' paramnames = namesFromList $ boundByLambda lam @@ -889,7 +878,7 @@ FunDef lore -> SimpleM lore (FunDef (Wise lore)) simplifyFun (FunDef entry fname rettype params body) = do rettype' <- simplify rettype - params' <- mapM (simplifyParam simplify) params - let ds = map diet (retTypeValues rettype') + params' <- mapM (traverse simplify) params + let ds = map (diet . declExtTypeOf) rettype' body' <- bindFParams params $ insertAllStms $ simplifyBody ds body return $ FunDef entry fname rettype' params' body' diff --git a/src/Futhark/Optimise/Simplify/Lore.hs b/src/Futhark/Optimise/Simplify/Lore.hs --- a/src/Futhark/Optimise/Simplify/Lore.hs +++ b/src/Futhark/Optimise/Simplify/Lore.hs @@ -19,7 +19,7 @@ , addWisdomToPattern , mkWiseBody , mkWiseLetStm - , mkWiseExpAttr + , mkWiseExpDec , CanBeWise (..) ) @@ -30,13 +30,13 @@ import qualified Data.Kind import qualified Data.Map.Strict as M -import Futhark.Representation.AST -import Futhark.Representation.AST.Attributes.Ranges -import Futhark.Representation.AST.Attributes.Aliases -import Futhark.Representation.Aliases +import Futhark.IR +import Futhark.IR.Prop.Ranges +import Futhark.IR.Prop.Aliases +import Futhark.IR.Aliases (unNames, Names' (..), VarAliases, ConsumedInExp) -import qualified Futhark.Representation.Aliases as Aliases -import qualified Futhark.Representation.Ranges as Ranges +import qualified Futhark.IR.Aliases as Aliases +import qualified Futhark.IR.Ranges as Ranges import Futhark.Binder import Futhark.Transform.Rename import Futhark.Transform.Substitute @@ -69,7 +69,7 @@ instance FreeIn ExpWisdom where freeIn' = mempty -instance FreeAttr ExpWisdom where +instance FreeDec ExpWisdom where precomputed = const . fvNames . unNames . expWisdomFree instance Substitute ExpWisdom where @@ -104,16 +104,16 @@ freeIn' (BodyWisdom als cons rs free) = freeIn' als <> freeIn' cons <> freeIn' rs <> freeIn' free -instance FreeAttr BodyWisdom where +instance FreeDec BodyWisdom where precomputed = const . fvNames . unNames . bodyWisdomFree -instance (Annotations lore, - CanBeWise (Op lore)) => Annotations (Wise lore) where - type LetAttr (Wise lore) = (VarWisdom, LetAttr lore) - type ExpAttr (Wise lore) = (ExpWisdom, ExpAttr lore) - type BodyAttr (Wise lore) = (BodyWisdom, BodyAttr lore) - type FParamAttr (Wise lore) = FParamAttr lore - type LParamAttr (Wise lore) = LParamAttr lore +instance (Decorations lore, + CanBeWise (Op lore)) => Decorations (Wise lore) where + type LetDec (Wise lore) = (VarWisdom, LetDec lore) + type ExpDec (Wise lore) = (ExpWisdom, ExpDec lore) + type BodyDec (Wise lore) = (BodyWisdom, BodyDec lore) + type FParamInfo (Wise lore) = FParamInfo lore + type LParamInfo (Wise lore) = LParamInfo lore type RetType (Wise lore) = RetType lore type BranchType (Wise lore) = BranchType lore type Op (Wise lore) = OpWithWisdom (Op lore) @@ -125,28 +125,28 @@ scope <- asksScope removeScopeWisdom runReaderT m scope -instance (Attributes lore, CanBeWise (Op lore)) => Attributes (Wise lore) where +instance (ASTLore lore, CanBeWise (Op lore)) => ASTLore (Wise lore) where expTypesFromPattern = withoutWisdom . expTypesFromPattern . removePatternWisdom -instance PrettyAnnot (PatElemT attr) => PrettyAnnot (PatElemT (VarWisdom, attr)) where +instance PrettyAnnot (PatElemT dec) => PrettyAnnot (PatElemT (VarWisdom, dec)) where ppAnnot = ppAnnot . fmap snd instance (PrettyLore lore, CanBeWise (Op lore)) => PrettyLore (Wise lore) where - ppExpLore (_, attr) = ppExpLore attr . removeExpWisdom + ppExpLore (_, dec) = ppExpLore dec . removeExpWisdom -instance AliasesOf (VarWisdom, attr) where +instance AliasesOf (VarWisdom, dec) where aliasesOf = unNames . varWisdomAliases . fst -instance RangeOf (VarWisdom, attr) where +instance RangeOf (VarWisdom, dec) where rangeOf = varWisdomRange . fst -instance RangesOf (BodyWisdom, attr) where +instance RangesOf (BodyWisdom, dec) where rangesOf = bodyWisdomRanges . fst -instance (Attributes lore, CanBeWise (Op lore)) => Aliased (Wise lore) where - bodyAliases = map unNames . bodyWisdomAliases . fst . bodyAttr - consumedInBody = unNames . bodyWisdomConsumed . fst . bodyAttr +instance (ASTLore lore, CanBeWise (Op lore)) => Aliased (Wise lore) where + bodyAliases = map unNames . bodyWisdomAliases . fst . bodyDec + consumedInBody = unNames . bodyWisdomConsumed . fst . bodyDec removeWisdom :: CanBeWise (Op lore) => Rephraser Identity (Wise lore) lore removeWisdom = Rephraser { rephraseExpLore = return . snd @@ -161,17 +161,17 @@ removeScopeWisdom :: Scope (Wise lore) -> Scope lore removeScopeWisdom = M.map unAlias - where unAlias (LetInfo (_, attr)) = LetInfo attr - unAlias (FParamInfo attr) = FParamInfo attr - unAlias (LParamInfo attr) = LParamInfo attr - unAlias (IndexInfo it) = IndexInfo it + where unAlias (LetName (_, dec)) = LetName dec + unAlias (FParamName dec) = FParamName dec + unAlias (LParamName dec) = LParamName dec + unAlias (IndexName it) = IndexName it addScopeWisdom :: Scope lore -> Scope (Wise lore) addScopeWisdom = M.map alias - where alias (LetInfo attr) = LetInfo (VarWisdom mempty unknownRange, attr) - alias (FParamInfo attr) = FParamInfo attr - alias (LParamInfo attr) = LParamInfo attr - alias (IndexInfo it) = IndexInfo it + where alias (LetName dec) = LetName (VarWisdom mempty unknownRange, dec) + alias (FParamName dec) = FParamName dec + alias (LParamName dec) = LParamName dec + alias (IndexName it) = IndexName it removeFunDefWisdom :: CanBeWise (Op lore) => FunDef (Wise lore) -> FunDef lore removeFunDefWisdom = runIdentity . rephraseFunDef removeWisdom @@ -191,7 +191,7 @@ removePatternWisdom :: PatternT (VarWisdom, a) -> PatternT a removePatternWisdom = runIdentity . rephrasePattern (return . snd) -addWisdomToPattern :: (Attributes lore, CanBeWise (Op lore)) => +addWisdomToPattern :: (ASTLore lore, CanBeWise (Op lore)) => Pattern lore -> Exp (Wise lore) -> Pattern (Wise lore) @@ -201,30 +201,30 @@ (zipWith addRanges valals ranges) where (ctxals, valals) = Aliases.mkPatternAliases pat e addRanges patElem range = - let (als, innerlore) = patElemAttr patElem + let (als, innerlore) = patElemDec patElem in patElem `setPatElemLore` (VarWisdom als range, innerlore) ranges = expRanges e -mkWiseBody :: (Attributes lore, CanBeWise (Op lore)) => - BodyAttr lore -> Stms (Wise lore) -> Result -> Body (Wise lore) +mkWiseBody :: (ASTLore lore, CanBeWise (Op lore)) => + BodyDec lore -> Stms (Wise lore) -> Result -> Body (Wise lore) mkWiseBody innerlore bnds res = Body (BodyWisdom aliases consumed ranges (Names' $ freeIn $ freeInStmsAndRes bnds res), innerlore) bnds res where (aliases, consumed) = Aliases.mkBodyAliases bnds res ranges = Ranges.mkBodyRanges bnds res -mkWiseLetStm :: (Attributes lore, CanBeWise (Op lore)) => +mkWiseLetStm :: (ASTLore lore, CanBeWise (Op lore)) => Pattern lore - -> StmAux (ExpAttr lore) -> Exp (Wise lore) + -> StmAux (ExpDec lore) -> Exp (Wise lore) -> Stm (Wise lore) -mkWiseLetStm pat (StmAux cs attr) e = +mkWiseLetStm pat (StmAux cs attrs dec) e = let pat' = addWisdomToPattern pat e - in Let pat' (StmAux cs $ mkWiseExpAttr pat' attr e) e + in Let pat' (StmAux cs attrs $ mkWiseExpDec pat' dec e) e -mkWiseExpAttr :: (Attributes lore, CanBeWise (Op lore)) => - Pattern (Wise lore) -> ExpAttr lore -> Exp (Wise lore) - -> ExpAttr (Wise lore) -mkWiseExpAttr pat explore e = +mkWiseExpDec :: (ASTLore lore, CanBeWise (Op lore)) => + Pattern (Wise lore) -> ExpDec lore -> Exp (Wise lore) + -> ExpDec (Wise lore) +mkWiseExpDec pat explore e = (ExpWisdom (Names' $ consumedInExp e) (Names' $ freeIn pat <> freeIn explore <> freeIn e), @@ -235,14 +235,14 @@ mkExpPat ctx val e = addWisdomToPattern (mkExpPat ctx val $ removeExpWisdom e) e - mkExpAttr pat e = - mkWiseExpAttr pat (mkExpAttr (removePatternWisdom pat) $ removeExpWisdom e) e + mkExpDec pat e = + mkWiseExpDec pat (mkExpDec (removePatternWisdom pat) $ removeExpWisdom e) e mkLetNames names e = do env <- asksScope removeScopeWisdom flip runReaderT env $ do - Let pat attr _ <- mkLetNames names $ removeExpWisdom e - return $ mkWiseLetStm pat attr e + Let pat dec _ <- mkLetNames names $ removeExpWisdom e + return $ mkWiseLetStm pat dec e mkBody bnds res = let Body bodylore _ _ = mkBody (fmap removeStmWisdom bnds) res diff --git a/src/Futhark/Optimise/Simplify/Rule.hs b/src/Futhark/Optimise/Simplify/Rule.hs --- a/src/Futhark/Optimise/Simplify/Rule.hs +++ b/src/Futhark/Optimise/Simplify/Rule.hs @@ -2,6 +2,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE Trustworthy #-} -- | This module defines the concept of a simplification rule for -- bindings. The intent is that you pass some context (such as symbol -- table) and a binding, and is given back a sequence of bindings that @@ -58,7 +59,7 @@ import qualified Futhark.Analysis.SymbolTable as ST import qualified Futhark.Analysis.UsageTable as UT -import Futhark.Representation.AST +import Futhark.IR import Futhark.Binder data RuleError = CannotSimplify @@ -73,15 +74,14 @@ instance Fail.MonadFail (RuleM lore) where fail = throwError . OtherError -instance (Attributes lore, BinderOps lore) => MonadBinder (RuleM lore) where +instance (ASTLore lore, BinderOps lore) => MonadBinder (RuleM lore) where type Lore (RuleM lore) = lore - mkExpAttrM pat e = RuleM $ mkExpAttrM pat e + mkExpDecM pat e = RuleM $ mkExpDecM pat e mkBodyM bnds res = RuleM $ mkBodyM bnds res mkLetNamesM pat e = RuleM $ mkLetNamesM pat e addStms = RuleM . addStms collectStms (RuleM m) = RuleM $ collectStms m - certifying cs (RuleM m) = RuleM $ certifying cs m -- | Execute a 'RuleM' action. If succesful, returns the result and a -- list of new bindings. Even if the action fail, there may still be @@ -108,17 +108,17 @@ | Skip -- ^ Don't bother. type RuleGeneric lore a = a -> Stm lore -> Rule lore -type RuleBasicOp lore a = (a -> Pattern lore -> StmAux (ExpAttr lore) -> +type RuleBasicOp lore a = (a -> Pattern lore -> StmAux (ExpDec lore) -> BasicOp -> Rule lore) -type RuleIf lore a = a -> Pattern lore -> StmAux (ExpAttr lore) -> +type RuleIf lore a = a -> Pattern lore -> StmAux (ExpDec lore) -> (SubExp, BodyT lore, BodyT lore, - IfAttr (BranchType lore)) -> + IfDec (BranchType lore)) -> Rule lore -type RuleDoLoop lore a = a -> Pattern lore -> StmAux (ExpAttr lore) -> +type RuleDoLoop lore a = a -> Pattern lore -> StmAux (ExpDec lore) -> ([(FParam lore, SubExp)], [(FParam lore, SubExp)], LoopForm lore, BodyT lore) -> Rule lore -type RuleOp lore a = a -> Pattern lore -> StmAux (ExpAttr lore) -> +type RuleOp lore a = a -> Pattern lore -> StmAux (ExpDec lore) -> Op lore -> Rule lore -- | A simplification rule takes some argument and a statement, and diff --git a/src/Futhark/Optimise/Simplify/Rules.hs b/src/Futhark/Optimise/Simplify/Rules.hs --- a/src/Futhark/Optimise/Simplify/Rules.hs +++ b/src/Futhark/Optimise/Simplify/Rules.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE Safe #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} -- | This module defines a collection of simplification rules, as per @@ -31,8 +32,8 @@ import Futhark.Optimise.Simplify.ClosedForm import Futhark.Optimise.Simplify.Rule import Futhark.Analysis.PrimExp.Convert -import Futhark.Representation.AST -import Futhark.Representation.AST.Attributes.Aliases +import Futhark.IR +import Futhark.IR.Prop.Aliases import Futhark.Construct import Futhark.Util @@ -125,7 +126,7 @@ mapM_ (uncurry letBindNames) $ dummyStms discard_ctx mapM_ (uncurry letBindNames) $ dummyStms discard_val return body' - letBind_ pat' $ DoLoop ctx' val' form body'' + letBind pat' $ DoLoop ctx' val' form body'' where pat_used = map (`UT.isUsedDirectly` used) $ patternValueNames pat used_vals = map fst $ filter snd $ zip (map (paramName . fst) val) pat_used usedAfterLoop = flip elem used_vals . paramName @@ -166,8 +167,8 @@ explpat'' = map fst explpat' (ctx', val') = splitAt (length implpat') merge' forM_ (invariant ++ implinvariant') $ \(v1,v2) -> - letBindNames_ [identName v1] $ BasicOp $ SubExp v2 - letBind_ (Pattern implpat'' explpat'') $ + letBindNames [identName v1] $ BasicOp $ SubExp v2 + letBind (Pattern implpat'' explpat'') $ DoLoop ctx' val' form loopbody' where merge = ctx ++ val res = bodyResult loopbody @@ -262,7 +263,7 @@ else do body' <- insertStmsM $ do addStms $ mconcat body_prefix_stms resultBodyM =<< bodyBind body - letBind_ pat $ DoLoop ctx val + letBind pat $ DoLoop ctx val (ForLoop i it num_iters $ catMaybes maybe_loop_vars) body' where seType (Var v) @@ -300,7 +301,7 @@ | all (notIndex . stmExp) x_stms -> do x_stms' <- collectStms_ $ certifying cs $ do addStms x_stms - letBindNames_ [paramName p] $ BasicOp $ SubExp se + letBindNames [paramName p] $ BasicOp $ SubExp se return (Nothing, x_stms') _ -> return (Just (p,arr), mempty) @@ -321,17 +322,17 @@ forM_ (ctx++val) $ \(mergevar, mergeinit) -> letBindNames [paramName mergevar] $ BasicOp $ SubExp mergeinit - letBindNames_ [i] $ BasicOp $ SubExp $ intConst it 0 + letBindNames [i] $ BasicOp $ SubExp $ intConst it 0 forM_ loop_vars $ \(p,arr) -> - letBindNames_ [paramName p] $ BasicOp $ Index arr $ + letBindNames [paramName p] $ BasicOp $ Index arr $ DimFix (intConst Int32 0) : fullSlice (paramType p) [] -- Some of the sizes in the types here might be temporarily wrong -- until copy propagation fixes it up. res <- bodyBind body forM_ (zip (patternNames pat) res) $ \(v, se) -> - letBindNames_ [v] $ BasicOp $ SubExp se + letBindNames [v] $ BasicOp $ SubExp se simplifKnownIterationLoop _ _ _ _ = Skip @@ -343,13 +344,13 @@ removeUnnecessaryCopy (vtable,used) (Pattern [] [d]) _ (Copy v) | not (v `UT.isConsumed` used), (not (v `UT.used` used) && consumable) || not (patElemName d `UT.isConsumed` used) = - Simplify $ letBindNames_ [patElemName d] $ BasicOp $ SubExp $ Var v + Simplify $ letBindNames [patElemName d] $ BasicOp $ SubExp $ Var v where -- We need to make sure we can even consume the original. -- This is currently a hacky check, much too conservative, -- because we don't have the information conveniently -- available. consumable = case M.lookup v $ ST.toScope vtable of - Just (FParamInfo info) -> unique $ declTypeOf info + Just (FParamName info) -> unique $ declTypeOf info _ -> False removeUnnecessaryCopy _ _ _ _ = Skip @@ -367,7 +368,7 @@ CmpLle -> True simplifyCmpOp _ _ (CmpOp cmp (Constant v1) (Constant v2)) = - constRes =<< BoolValue <$> doCmpOp cmp v1 v2 + constRes . BoolValue =<< doCmpOp cmp v1 v2 simplifyCmpOp look _ (CmpOp CmpEq{} (Constant (IntValue x)) (Var v)) | Just (BasicOp (ConvOp BToI{} b), cs) <- look v = @@ -573,26 +574,27 @@ Nothing constantFoldPrimFun :: BinderOps lore => TopDownRuleGeneric lore -constantFoldPrimFun _ (Let pat (StmAux cs _) (Apply fname args _ _)) +constantFoldPrimFun _ (Let pat (StmAux cs attrs _) (Apply fname args _ _)) | Just args' <- mapM (isConst . fst) args, Just (_, _, fun) <- M.lookup (nameToString fname) primFuns, Just result <- fun args' = - Simplify $ certifying cs $ letBind_ pat $ BasicOp $ SubExp $ Constant result + Simplify $ certifying cs $ attributing attrs $ + letBind pat $ BasicOp $ SubExp $ Constant result where isConst (Constant v) = Just v isConst _ = Nothing constantFoldPrimFun _ _ = Skip simplifyIndex :: BinderOps lore => BottomUpRuleBasicOp lore -simplifyIndex (vtable, used) pat@(Pattern [] [pe]) (StmAux cs _) (Index idd inds) +simplifyIndex (vtable, used) pat@(Pattern [] [pe]) (StmAux cs attrs _) (Index idd inds) | Just m <- simplifyIndexing vtable seType idd inds consumed = Simplify $ do res <- m - case res of + attributing attrs $ case res of SubExpResult cs' se -> certifying (cs<>cs') $ - letBindNames_ (patternNames pat) $ BasicOp $ SubExp se + letBindNames (patternNames pat) $ BasicOp $ SubExp se IndexResult extra_cs idd' inds' -> certifying (cs<>extra_cs) $ - letBindNames_ (patternNames pat) $ BasicOp $ Index idd' inds' + letBindNames (patternNames pat) $ BasicOp $ Index idd' inds' where consumed = patElemName pe `UT.isConsumed` used seType (Var v) = ST.lookupType v vtable seType (Constant v) = Just $ Prim $ primValueType v @@ -616,14 +618,14 @@ Just (ST.Indexed cs e) <- ST.index idd inds' vtable, worthInlining e, all (`ST.elem` vtable) (unCertificates cs) -> - Just $ SubExpResult cs <$> (letSubExp "index_primexp" =<< toExp e) + Just $ SubExpResult cs <$> toSubExp "index_primexp" e | Just inds' <- sliceIndices inds, Just (ST.IndexedArray cs arr inds'') <- ST.index idd inds' vtable, all worthInlining inds'', all (`ST.elem` vtable) (unCertificates cs) -> Just $ IndexResult cs arr . map DimFix <$> - mapM (letSubExp "index_primexp" <=< toExp) inds'' + mapM (toSubExp "index_primexp") inds'' Nothing -> Nothing @@ -633,7 +635,7 @@ | [DimFix ii] <- inds, Just (Prim (IntType from_it)) <- seType ii -> Just $ - fmap (SubExpResult cs) $ letSubExp "index_iota" <=< toExp $ + fmap (SubExpResult cs) $ toSubExp "index_iota" $ ConvOpExp (SExt from_it to_it) (primExpFromSubExp (IntType from_it) ii) * primExpFromSubExp (IntType to_it) s + primExpFromSubExp (IntType to_it) x @@ -641,7 +643,7 @@ Just $ do i_offset' <- asIntS to_it i_offset i_stride' <- asIntS to_it i_stride - i_offset'' <- letSubExp "iota_offset" <=< toExp $ + i_offset'' <- toSubExp "iota_offset" $ primExpFromSubExp (IntType to_it) x + primExpFromSubExp (IntType to_it) s * primExpFromSubExp (IntType to_it) i_offset' @@ -735,7 +737,7 @@ (altres, altbnds) <- collectStms $ mkBranch xs_and_starts' altbody <- mkBodyM altbnds [altres] letSubExp "index_concat_branch" $ If cmp thisbody altbody $ - IfAttr [primBodyType res_t] IfNormal + IfDec [primBodyType res_t] IfNormal SubExpResult cs <$> mkBranch xs_and_starts Just (ArrayLit ses _, cs) @@ -797,7 +799,7 @@ concat_rearrange <- certifying (x_cs<>mconcat xs_cs) $ letExp "concat_rearrange" $ BasicOp $ Concat 0 x' xs' new_d - letBind_ pat $ BasicOp $ Rearrange perm concat_rearrange + letBind pat $ BasicOp $ Rearrange perm concat_rearrange where transposedBy perm1 v = case ST.lookupExp v vtable of Just (BasicOp (Rearrange perm2 v'), vcs) @@ -805,10 +807,11 @@ _ -> Nothing -- concat xs (concat ys zs) == concat xs ys zs -simplifyConcat (vtable, _) pat (StmAux cs _) (Concat i x xs new_d) +simplifyConcat (vtable, _) pat (StmAux cs attrs _) (Concat i x xs new_d) | x' /= x || concat xs' /= xs = Simplify $ certifying (cs<>x_cs<>mconcat xs_cs) $ - letBind_ pat $ BasicOp $ Concat i x' (zs++concat xs') new_d + attributing attrs $ letBind pat $ + BasicOp $ Concat i x' (zs++concat xs') new_d where (x':zs, x_cs) = isConcat x (xs', xs_cs) = unzip $ map isConcat xs isConcat v = case ST.lookupBasicOp v vtable of @@ -817,11 +820,11 @@ -- If concatenating a bunch of array literals (or equivalent -- replicate), just construct the array literal instead. -simplifyConcat (vtable, _) pat (StmAux cs _) (Concat 0 x xs _) +simplifyConcat (vtable, _) pat aux (Concat 0 x xs _) | Just (vs, vcs) <- unzip <$> mapM isArrayLit (x:xs) = Simplify $ do rt <- rowType <$> lookupType x - certifying (cs <> mconcat vcs) $ - letBind_ pat $ BasicOp $ ArrayLit (concat vs) rt + certifying (mconcat vcs) $ auxing aux $ + letBind pat $ BasicOp $ ArrayLit (concat vs) rt where isArrayLit v | Just (Replicate shape se, vcs) <- ST.lookupBasicOp v vtable, unitShape shape = Just ([se], vcs) @@ -836,12 +839,12 @@ ruleIf :: BinderOps lore => TopDownRuleIf lore -ruleIf _ pat _ (e1, tb, fb, IfAttr _ ifsort) +ruleIf _ pat _ (e1, tb, fb, IfDec _ ifsort) | Just branch <- checkBranch, ifsort /= IfFallback || isCt1 e1 = Simplify $ do let ses = bodyResult branch addStms $ bodyStms branch - sequence_ [ letBindNames_ [patElemName p] $ BasicOp $ SubExp se + sequence_ [ letBindNames [patElemName p] $ BasicOp $ SubExp se | (p,se) <- zip (patternElements pat) ses] where checkBranch @@ -856,29 +859,29 @@ -- if c then True else v == c || v ruleIf _ pat _ (cond, Body _ tstms [Constant (BoolValue True)], - Body _ fstms [se], IfAttr ts _) - | null tstms, null fstms, [Prim Bool] <- bodyTypeValues ts = - Simplify $ letBind_ pat $ BasicOp $ BinOp LogOr cond se + Body _ fstms [se], IfDec ts _) + | null tstms, null fstms, [Prim Bool] <- map extTypeOf ts = + Simplify $ letBind pat $ BasicOp $ BinOp LogOr cond se -- When type(x)==bool, if c then x else y == (c && x) || (!c && y) -ruleIf _ pat _ (cond, tb, fb, IfAttr ts _) +ruleIf _ pat _ (cond, tb, fb, IfDec ts _) | Body _ tstms [tres] <- tb, Body _ fstms [fres] <- fb, all (safeExp . stmExp) $ tstms <> fstms, - all (==Prim Bool) $ bodyTypeValues ts = Simplify $ do + all ((==Prim Bool) . extTypeOf) ts = Simplify $ do addStms tstms addStms fstms e <- eBinOp LogOr (pure $ BasicOp $ BinOp LogAnd cond tres) (eBinOp LogAnd (pure $ BasicOp $ UnOp Not cond) (pure $ BasicOp $ SubExp fres)) - letBind_ pat e + letBind pat e -ruleIf _ pat _ (_, tbranch, _, IfAttr _ IfFallback) +ruleIf _ pat _ (_, tbranch, _, IfDec _ IfFallback) | null $ patternContextNames pat, all (safeExp . stmExp) $ bodyStms tbranch = Simplify $ do let ses = bodyResult tbranch addStms $ bodyStms tbranch - sequence_ [ letBindNames_ [patElemName p] $ BasicOp $ SubExp se + sequence_ [ letBindNames [patElemName p] $ BasicOp $ SubExp se | (p,se) <- zip (patternElements pat) ses] ruleIf _ pat _ (cond, tb, fb, _) @@ -886,11 +889,11 @@ Body _ _ [Constant (IntValue f)] <- fb = if oneIshInt t && zeroIshInt f then Simplify $ - letBind_ pat $ BasicOp $ ConvOp (BToI (intValueType t)) cond + letBind pat $ BasicOp $ ConvOp (BToI (intValueType t)) cond else if zeroIshInt t && oneIshInt f then Simplify $ do cond_neg <- letSubExp "cond_neg" $ BasicOp $ UnOp Not cond - letBind_ pat $ BasicOp $ ConvOp (BToI (intValueType t)) cond_neg + letBind pat $ BasicOp $ ConvOp (BToI (intValueType t)) cond_neg else Skip ruleIf _ _ _ _ = Skip @@ -899,7 +902,7 @@ -- either invariant to the branches (only done for results in the -- context), or the same in both branches. hoistBranchInvariant :: BinderOps lore => TopDownRuleIf lore -hoistBranchInvariant _ pat _ (cond, tb, fb, IfAttr ret ifsort) = Simplify $ do +hoistBranchInvariant _ pat _ (cond, tb, fb, IfDec ret ifsort) = Simplify $ do let tses = bodyResult tb fses = bodyResult fb (hoistings, (pes, ts, res)) <- @@ -918,8 +921,8 @@ -- less existential. tb'' <- reshapeBodyResults tb' $ map extTypeOf ret' fb'' <- reshapeBodyResults fb' $ map extTypeOf ret' - letBind_ (Pattern ctx_pes val_pes) $ - If cond tb'' fb'' (IfAttr ret' ifsort) + letBind (Pattern ctx_pes val_pes) $ + If cond tb'' fb'' (IfDec ret' ifsort) else cannotSimplify where num_ctx = length $ patternContextElements pat bound_in_branches = namesFromList $ concatMap (patternNames . stmPattern) $ @@ -935,7 +938,7 @@ branchInvariant (pe, t, (tse, fse)) -- Do both branches return the same value? | tse == fse = do - letBindNames_ [patElemName pe] $ BasicOp $ SubExp tse + letBindNames [patElemName pe] $ BasicOp $ SubExp tse hoisted pe t -- Do both branches return values that are free in the @@ -944,10 +947,10 @@ | invariant tse, invariant fse, patternSize pat > 1, Prim _ <- patElemType pe, not $ sizeOfMem $ patElemName pe = do bt <- expTypesFromPattern $ Pattern [] [pe] - letBindNames_ [patElemName pe] =<< + letBindNames [patElemName pe] =<< (If cond <$> resultBodyM [tse] <*> resultBodyM [fse] - <*> pure (IfAttr bt ifsort)) + <*> pure (IfDec bt ifsort)) hoisted pe t | otherwise = @@ -1035,19 +1038,19 @@ -- Check all the simpleRules. ruleBasicOp vtable pat aux op | Just (op', cs) <- msum [ rule defOf seType op | rule <- simpleRules ] = - Simplify $ certifying (cs <> stmAuxCerts aux) $ letBind_ pat $ BasicOp op' + Simplify $ certifying (cs <> stmAuxCerts aux) $ letBind pat $ BasicOp op' where defOf = (`ST.lookupExp` vtable) seType (Var v) = ST.lookupType v vtable seType (Constant v) = Just $ Prim $ primValueType v ruleBasicOp vtable pat _ (Update src _ (Var v)) | Just (BasicOp Scratch{}, _) <- ST.lookupExp v vtable = - Simplify $ letBind_ pat $ BasicOp $ SubExp $ Var src + Simplify $ letBind pat $ BasicOp $ SubExp $ Var src ruleBasicOp vtable pat _ (Update dest destis (Var v)) | Just (e, _) <- ST.lookupExp v vtable, arrayFrom e = - Simplify $ letBind_ pat $ BasicOp $ SubExp $ Var dest + Simplify $ letBind pat $ BasicOp $ SubExp $ Var dest where arrayFrom (BasicOp (Copy copy_v)) | Just (e',_) <- ST.lookupExp copy_v vtable = arrayFrom e' @@ -1070,20 +1073,20 @@ Var v | not $ null $ sliceDims is -> do v_reshaped <- letExp (baseString v ++ "_reshaped") $ BasicOp $ Reshape (map DimNew $ arrayDims dest_t) v - letBind_ pat $ BasicOp $ Copy v_reshaped + letBind pat $ BasicOp $ Copy v_reshaped - _ -> letBind_ pat $ BasicOp $ ArrayLit [se] $ rowType dest_t + _ -> letBind pat $ BasicOp $ ArrayLit [se] $ rowType dest_t -- | Simplify a chain of in-place updates and copies. This chain is -- often produced by in-place lowering. -ruleBasicOp vtable pat (StmAux cs1 _) (Update dest1 is1 (Var v1)) +ruleBasicOp vtable pat (StmAux cs1 attrs _) (Update dest1 is1 (Var v1)) | Just (Update dest2 is2 se2, cs2) <- ST.lookupBasicOp v1 vtable, Just (Copy v3, cs3) <- ST.lookupBasicOp dest2 vtable, Just (Index v4 is4, cs4) <- ST.lookupBasicOp v3 vtable, is4 == is1, v4 == dest1 = Simplify $ certifying (cs1 <> cs2 <> cs3 <> cs4) $ do is5 <- sliceSlice is1 is2 - letBind_ pat $ BasicOp $ Update dest1 is5 se2 + attributing attrs $ letBind pat $ BasicOp $ Update dest1 is5 se2 -- | If we are comparing X against the result of a branch of the form -- @if P then Y else Z@ then replace comparison with '(P && X == Y) || @@ -1112,7 +1115,7 @@ letSubExp "not_p" $ BasicOp $ UnOp Not p not_p_and_eq_x_z <- letSubExp "p_and_eq_x_y" $ BasicOp $ BinOp LogAnd not_p eq_x_z - letBind_ pat $ + letBind pat $ BasicOp $ BinOp LogOr p_and_eq_x_y not_p_and_eq_x_z simplifyWith _ _ = Nothing @@ -1124,31 +1127,31 @@ zip (bodyResult tbranch) (bodyResult fbranch) ruleBasicOp _ pat _ (Replicate (Shape []) se@Constant{}) = - Simplify $ letBind_ pat $ BasicOp $ SubExp se + Simplify $ letBind pat $ BasicOp $ SubExp se ruleBasicOp _ pat _ (Replicate (Shape []) (Var v)) = Simplify $ do v_t <- lookupType v - letBind_ pat $ BasicOp $ if primType v_t + letBind pat $ BasicOp $ if primType v_t then SubExp $ Var v else Copy v ruleBasicOp vtable pat _ (Replicate shape (Var v)) | Just (BasicOp (Replicate shape2 se), cs) <- ST.lookupExp v vtable = - Simplify $ certifying cs $ letBind_ pat $ BasicOp $ Replicate (shape<>shape2) se + Simplify $ certifying cs $ letBind pat $ BasicOp $ Replicate (shape<>shape2) se -- | Turn array literals with identical elements into replicates. ruleBasicOp _ pat _ (ArrayLit (se:ses) _) | all (==se) ses = Simplify $ let n = constant (fromIntegral (length ses) + 1 :: Int32) - in letBind_ pat $ BasicOp $ Replicate (Shape [n]) se + in letBind pat $ BasicOp $ Replicate (Shape [n]) se -ruleBasicOp vtable pat (StmAux cs _) (Index idd slice) +ruleBasicOp vtable pat aux (Index idd slice) | Just inds <- sliceIndices slice, Just (BasicOp (Reshape newshape idd2), idd_cs) <- ST.lookupExp idd vtable, length newshape == length inds = Simplify $ case shapeCoercion newshape of Just _ -> - certifying (cs<>idd_cs) $ - letBind_ pat $ BasicOp $ Index idd2 slice + certifying idd_cs $ auxing aux $ + letBind pat $ BasicOp $ Index idd2 slice Nothing -> do -- Linearise indices and map to old index space. oldshape <- arrayDims <$> lookupType idd2 @@ -1157,65 +1160,66 @@ (map (primExpFromSubExp int32) $ newDims newshape) (map (primExpFromSubExp int32) inds) new_inds' <- - mapM (letSubExp "new_index" <=< toExp . asInt32PrimExp) new_inds - certifying (cs<>idd_cs) $ - letBind_ pat $ BasicOp $ Index idd2 $ map DimFix new_inds' + mapM (toSubExp "new_index" . asInt32PrimExp) new_inds + certifying idd_cs $ auxing aux $ + letBind pat $ BasicOp $ Index idd2 $ map DimFix new_inds' ruleBasicOp _ pat _ (BinOp (Pow t) e1 e2) | e1 == intConst t 2 = - Simplify $ letBind_ pat $ BasicOp $ BinOp (Shl t) (intConst t 1) e2 + Simplify $ letBind pat $ BasicOp $ BinOp (Shl t) (intConst t 1) e2 -- Handle identity permutation. ruleBasicOp _ pat _ (Rearrange perm v) | sort perm == perm = - Simplify $ letBind_ pat $ BasicOp $ SubExp $ Var v + Simplify $ letBind pat $ BasicOp $ SubExp $ Var v -ruleBasicOp vtable pat (StmAux cs _) (Rearrange perm v) +ruleBasicOp vtable pat aux (Rearrange perm v) | Just (BasicOp (Rearrange perm2 e), v_cs) <- ST.lookupExp v vtable = -- Rearranging a rearranging: compose the permutations. - Simplify $ certifying (cs<>v_cs) $ - letBind_ pat $ BasicOp $ Rearrange (perm `rearrangeCompose` perm2) e + Simplify $ certifying v_cs $ auxing aux $ + letBind pat $ BasicOp $ Rearrange (perm `rearrangeCompose` perm2) e -ruleBasicOp vtable pat (StmAux cs _) (Rearrange perm v) +ruleBasicOp vtable pat aux (Rearrange perm v) | Just (BasicOp (Rotate offsets v2), v_cs) <- ST.lookupExp v vtable, Just (BasicOp (Rearrange perm3 v3), v2_cs) <- ST.lookupExp v2 vtable = Simplify $ do let offsets' = rearrangeShape (rearrangeInverse perm3) offsets rearrange_rotate <- letExp "rearrange_rotate" $ BasicOp $ Rotate offsets' v3 - certifying (cs<>v_cs<>v2_cs) $ - letBind_ pat $ BasicOp $ Rearrange (perm `rearrangeCompose` perm3) rearrange_rotate + certifying (v_cs<>v2_cs) $ auxing aux $ + letBind pat $ BasicOp $ Rearrange (perm `rearrangeCompose` perm3) rearrange_rotate -- Rearranging a replicate where the outer dimension is left untouched. -ruleBasicOp vtable pat (StmAux cs _) (Rearrange perm v1) +ruleBasicOp vtable pat aux (Rearrange perm v1) | Just (BasicOp (Replicate dims (Var v2)), v1_cs) <- ST.lookupExp v1 vtable, num_dims <- shapeRank dims, (rep_perm, rest_perm) <- splitAt num_dims perm, not $ null rest_perm, - rep_perm == [0..length rep_perm-1] = Simplify $ certifying (cs<>v1_cs) $ do + rep_perm == [0..length rep_perm-1] = + Simplify $ certifying v1_cs $ auxing aux $ do v <- letSubExp "rearrange_replicate" $ BasicOp $ Rearrange (map (subtract num_dims) rest_perm) v2 - letBind_ pat $ BasicOp $ Replicate dims v + letBind pat $ BasicOp $ Replicate dims v -- A zero-rotation is identity. ruleBasicOp _ pat _ (Rotate offsets v) - | all isCt0 offsets = Simplify $ letBind_ pat $ BasicOp $ SubExp $ Var v + | all isCt0 offsets = Simplify $ letBind pat $ BasicOp $ SubExp $ Var v -ruleBasicOp vtable pat (StmAux cs _) (Rotate offsets v) +ruleBasicOp vtable pat aux (Rotate offsets v) | Just (BasicOp (Rearrange perm v2), v_cs) <- ST.lookupExp v vtable, Just (BasicOp (Rotate offsets2 v3), v2_cs) <- ST.lookupExp v2 vtable = Simplify $ do let offsets2' = rearrangeShape (rearrangeInverse perm) offsets2 addOffsets x y = letSubExp "summed_offset" $ BasicOp $ BinOp (Add Int32 OverflowWrap) x y offsets' <- zipWithM addOffsets offsets offsets2' rotate_rearrange <- - certifying cs $ letExp "rotate_rearrange" $ BasicOp $ Rearrange perm v3 + auxing aux $ letExp "rotate_rearrange" $ BasicOp $ Rearrange perm v3 certifying (v_cs <> v2_cs) $ - letBind_ pat $ BasicOp $ Rotate offsets' rotate_rearrange + letBind pat $ BasicOp $ Rotate offsets' rotate_rearrange -- Combining Rotates. -ruleBasicOp vtable pat (StmAux cs _) (Rotate offsets1 v) +ruleBasicOp vtable pat aux (Rotate offsets1 v) | Just (BasicOp (Rotate offsets2 v2), v_cs) <- ST.lookupExp v vtable = Simplify $ do offsets <- zipWithM add offsets1 offsets2 - certifying (cs<>v_cs) $ - letBind_ pat $ BasicOp $ Rotate offsets v2 + certifying v_cs $ auxing aux $ + letBind pat $ BasicOp $ Rotate offsets v2 where add x y = letSubExp "offset" $ BasicOp $ BinOp (Add Int32 OverflowWrap) x y -- If we see an Update with a scalar where the value to be written is @@ -1223,7 +1227,7 @@ -- Update with a slice of that array. This matters when the arrays -- are far away (on the GPU, say), because it avoids a copy of the -- scalar to and from the host. -ruleBasicOp vtable pat (StmAux cs_x _) (Update arr_x slice_x (Var v)) +ruleBasicOp vtable pat aux (Update arr_x slice_x (Var v)) | Just _ <- sliceIndices slice_x, Just (Index arr_y slice_y, cs_y) <- ST.lookupBasicOp v vtable, ST.available arr_y vtable, @@ -1234,8 +1238,8 @@ let slice_x' = slice_x_bef ++ [DimSlice i (intConst Int32 1) (intConst Int32 1)] slice_y' = slice_y_bef ++ [DimSlice j (intConst Int32 1) (intConst Int32 1)] v' <- letExp (baseString v ++ "_slice") $ BasicOp $ Index arr_y slice_y' - certifying (cs_x <> cs_y) $ - letBind_ pat $ BasicOp $ Update arr_x slice_x' $ Var v' + certifying cs_y $ auxing aux $ + letBind pat $ BasicOp $ Update arr_x slice_x' $ Var v' ruleBasicOp _ _ _ _ = Skip @@ -1245,7 +1249,7 @@ -- if *none* of the return values are used, but this rule is more -- precise. removeDeadBranchResult :: BinderOps lore => BottomUpRuleIf lore -removeDeadBranchResult (_, used) pat _ (e1, tb, fb, IfAttr rettype ifsort) +removeDeadBranchResult (_, used) pat _ (e1, tb, fb, IfDec rettype ifsort) | -- Only if there is no existential context... patternSize pat == length rettype, -- Figure out which of the names in 'pat' are used... @@ -1263,7 +1267,7 @@ fb' = fb { bodyResult = pick fses } pat' = pick $ patternElements pat rettype' = pick rettype - in Simplify $ letBind_ (Pattern [] pat') $ If e1 tb' fb' $ IfAttr rettype' ifsort + in Simplify $ letBind (Pattern [] pat') $ If e1 tb' fb' $ IfDec rettype' ifsort | otherwise = Skip diff --git a/src/Futhark/Optimise/Sink.hs b/src/Futhark/Optimise/Sink.hs --- a/src/Futhark/Optimise/Sink.hs +++ b/src/Futhark/Optimise/Sink.hs @@ -52,9 +52,9 @@ import qualified Futhark.Analysis.Alias as Alias import qualified Futhark.Analysis.Range as Range import qualified Futhark.Analysis.SymbolTable as ST -import Futhark.Representation.Aliases -import Futhark.Representation.Ranges -import Futhark.Representation.Kernels +import Futhark.IR.Aliases +import Futhark.IR.Ranges +import Futhark.IR.Kernels import Futhark.Pass -- We do not care about ranges, but in order to use ST.SymbolTable @@ -79,9 +79,9 @@ optimiseBranch :: SymbolTable -> Sinking -> Body SinkLore -> (Body SinkLore, Sunk) -optimiseBranch vtable sinking (Body attr stms res) = +optimiseBranch vtable sinking (Body dec stms res) = let (stms', stms_sunk) = optimiseStms vtable sinking' stms $ freeIn res - in (Body attr (sunk_stms <> stms') res, + in (Body dec (sunk_stms <> stms') res, sunk <> stms_sunk) where free_in_stms = freeIn stms <> freeIn res (sinking_here, sinking') = M.partitionWithKey sunkHere sinking @@ -164,16 +164,17 @@ optimiseBody :: SymbolTable -> Sinking -> Body SinkLore -> (Body SinkLore, Sunk) -optimiseBody vtable sinking (Body attr stms res) = +optimiseBody vtable sinking (Body dec stms res) = let (stms', sunk) = optimiseStms vtable sinking stms $ freeIn res - in (Body attr stms' res, sunk) + in (Body dec stms' res, sunk) optimiseKernelBody :: SymbolTable -> Sinking -> KernelBody SinkLore -> (KernelBody SinkLore, Sunk) -optimiseKernelBody vtable sinking (KernelBody attr stms res) = +optimiseKernelBody vtable sinking (KernelBody dec stms res) = let (stms', sunk) = optimiseStms vtable sinking stms $ freeIn res - in (KernelBody attr stms' res, sunk) + in (KernelBody dec stms' res, sunk) +-- | The pass definition. sink :: Pass Kernels Kernels sink = Pass "sink" "move memory loads closer to their uses" $ fmap (removeProgAliases . removeProgRanges) . diff --git a/src/Futhark/Optimise/TileLoops.hs b/src/Futhark/Optimise/TileLoops.hs --- a/src/Futhark/Optimise/TileLoops.hs +++ b/src/Futhark/Optimise/TileLoops.hs @@ -15,11 +15,12 @@ import Prelude hiding (quot) import Futhark.MonadFreshNames -import Futhark.Representation.Kernels +import Futhark.IR.Kernels import Futhark.Transform.Rename import Futhark.Pass import Futhark.Tools +-- | The pass definition. tileLoops :: Pass Kernels Kernels tileLoops = Pass "tile loops" "Tile stream loops inside kernels" $ \(Prog consts funs) -> @@ -128,7 +129,7 @@ merge_params = map fst merge maybe_tiled <- - localScope (M.insert i (IndexInfo it) $ scopeOfFParams merge_params) $ + localScope (M.insert i (IndexName it) $ scopeOfFParams merge_params) $ tileInBody branch_variant' variance initial_lvl initial_space (map paramType merge_params) $ mkBody (bodyStms loopbody) (bodyResult loopbody) @@ -240,7 +241,7 @@ tileDoLoop :: SegSpace -> VarianceTable -> Stms Kernels -> Names -> (Stms Kernels, Tiling, TiledBody) - -> [Type] -> Pattern Kernels -> StmAux (ExpAttr Kernels) + -> [Type] -> Pattern Kernels -> StmAux (ExpDec Kernels) -> [(FParam Kernels, SubExp)] -> VName -> IntType -> SubExp -> Stms Kernels -> Result -> TileM (Stms Kernels, Tiling, TiledBody) @@ -286,7 +287,7 @@ let indexMergeParams slice = localScope (scopeOfFParams mergeparams') $ forM_ (zip mergeparams mergeparams') $ \(to, from) -> - letBindNames_ [paramName to] $ BasicOp $ Index (paramName from) $ + letBindNames [paramName to] $ BasicOp $ Index (paramName from) $ fullSlice (paramType from) slice loopbody' <- runBodyBinder $ resultBody . map Var <$> @@ -416,7 +417,7 @@ tilingSegMap tiling "thread_res" (scalarLevel tiling) ResultPrivate $ \in_bounds slice -> do -- Read our per-thread result from the tiled loop. forM_ (zip (patternNames pat) accs') $ \(us, everyone) -> - letBindNames_ [us] $ BasicOp $ Index everyone slice + letBindNames [us] $ BasicOp $ Index everyone slice if poststms == mempty then do -- The privstms may still be necessary for the result. @@ -505,7 +506,7 @@ mkReadPreludeValues prestms_live_arrs prestms_live slice = fmap mconcat $ forM (zip prestms_live_arrs prestms_live) $ \(arr, v) -> do arr_t <- lookupType arr - letBindNames_ [v] $ BasicOp $ Index arr $ fullSlice arr_t slice + letBindNames [v] $ BasicOp $ Index arr $ fullSlice arr_t slice tileReturns :: [(VName, SubExp)] -> [(SubExp, SubExp)] -> VName -> Binder Kernels KernelResult tileReturns dims_on_top dims arr = do @@ -538,7 +539,7 @@ reconstructGtids1D :: Count GroupSize SubExp -> VName -> VName -> VName -> Binder Kernels () reconstructGtids1D group_size gtid gid ltid = - letBindNames_ [gtid] =<< + letBindNames [gtid] =<< toExp (LeafExp gid int32 * primExpFromSubExp int32 (unCount group_size) + LeafExp ltid int32) @@ -672,7 +673,7 @@ num_whole_tiles <- letSubExp "num_whole_tiles" $ BasicOp $ BinOp (SQuot Int32) w tile_size return Tiling { tilingSegMap = \desc lvl' manifest f -> segMap1D desc lvl' manifest $ \ltid -> do - letBindNames_ [gtid] =<< + letBindNames [gtid] =<< toExp (LeafExp gid int32 * primExpFromSubExp int32 tile_size + LeafExp ltid int32) f (LeafExp gtid int32 .<. primExpFromSubExp int32 kdim) @@ -732,10 +733,10 @@ -> Binder Kernels () reconstructGtids2D tile_size (gtid_x, gtid_y) (gid_x, gid_y) (ltid_x, ltid_y) = do -- Reconstruct the original gtids from gid_x/gid_y and ltid_x/ltid_y. - letBindNames_ [gtid_x] =<< + letBindNames [gtid_x] =<< toExp (LeafExp gid_x int32 * primExpFromSubExp int32 tile_size + LeafExp ltid_x int32) - letBindNames_ [gtid_y] =<< + letBindNames [gtid_y] =<< toExp (LeafExp gid_y int32 * primExpFromSubExp int32 tile_size + LeafExp ltid_y int32) diff --git a/src/Futhark/Optimise/Unstream.hs b/src/Futhark/Optimise/Unstream.hs --- a/src/Futhark/Optimise/Unstream.hs +++ b/src/Futhark/Optimise/Unstream.hs @@ -9,11 +9,12 @@ import Control.Monad.Reader import Futhark.MonadFreshNames -import Futhark.Representation.Kernels +import Futhark.IR.Kernels import Futhark.Pass import Futhark.Tools import qualified Futhark.Transform.FirstOrderTransform as FOT +-- | The pass definition. unstream :: Pass Kernels Kernels unstream = Pass "unstream" "sequentialise remaining SOACs" $ intraproceduralTransformation optimise diff --git a/src/Futhark/Pass.hs b/src/Futhark/Pass.hs --- a/src/Futhark/Pass.hs +++ b/src/Futhark/Pass.hs @@ -1,9 +1,8 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE Strict #-} -{-# LANGUAGE StrictData #-} --- | Definition of a polymorphic (generic) pass that can work with programs of any --- lore. +-- | Definition of a polymorphic (generic) pass that can work with +-- programs of any lore. module Futhark.Pass ( PassM , runPassM @@ -25,7 +24,7 @@ import Prelude hiding (log) import Futhark.Error -import Futhark.Representation.AST +import Futhark.IR import Futhark.Util.Log import Futhark.MonadFreshNames @@ -93,6 +92,11 @@ let ((x', log), src') = runState (runPassM (f a)) src in (x', log, src') +-- | Apply some operation to the top-level constants. Then applies an +-- operation to all the function function definitions, which are also +-- given the transformed constants so they can be brought into scope. +-- The function definition transformations are run in parallel (with +-- 'parPass'), since they cannot affect each other. intraproceduralTransformationWithConsts :: (Stms fromlore -> PassM (Stms tolore)) -> (Stms tolore -> FunDef fromlore -> PassM (FunDef tolore)) -> Prog fromlore -> PassM (Prog tolore) @@ -101,6 +105,8 @@ funs' <- parPass (ft consts') funs return $ Prog consts' funs' +-- | Like 'intraproceduralTransformationWithConsts', but do not change +-- the top-level constants, and simply pass along their 'Scope'. intraproceduralTransformation :: (Scope lore -> Stms lore -> PassM (Stms lore)) -> Prog lore -> PassM (Prog lore) diff --git a/src/Futhark/Pass/ExpandAllocations.hs b/src/Futhark/Pass/ExpandAllocations.hs --- a/src/Futhark/Pass/ExpandAllocations.hs +++ b/src/Futhark/Pass/ExpandAllocations.hs @@ -20,10 +20,10 @@ import Futhark.MonadFreshNames import Futhark.Tools import Futhark.Pass -import Futhark.Representation.AST -import Futhark.Representation.KernelsMem -import Futhark.Representation.Kernels.Simplify as Kernels -import qualified Futhark.Representation.Mem.IxFun as IxFun +import Futhark.IR +import Futhark.IR.KernelsMem +import Futhark.IR.Kernels.Simplify as Kernels +import qualified Futhark.IR.Mem.IxFun as IxFun import Futhark.Pass.ExtractKernels.BlockedKernel (nonSegRed) import Futhark.Pass.ExtractKernels.ToKernels (segThread) import Futhark.Pass.ExplicitAllocations.Kernels (explicitAllocationsInStms) @@ -34,7 +34,7 @@ import Futhark.Util.IntegralExp import Futhark.Util (mapAccumLM) - +-- | The memory expansion pass definition. expandAllocations :: Pass KernelsMem KernelsMem expandAllocations = Pass "expand allocations" "Expand allocations" $ @@ -72,7 +72,7 @@ -- It is possible that we are unable to expand allocations in some -- code versions. If so, we can remove the offending branch. Only if -- both versions fail do we propagate the error. -transformStm (Let pat aux (If cond tbranch fbranch (IfAttr ts IfEquiv))) = do +transformStm (Let pat aux (If cond tbranch fbranch (IfDec ts IfEquiv))) = do tbranch' <- (Right <$> transformBody tbranch) `catchError` (return . Left) fbranch' <- (Right <$> transformBody fbranch) `catchError` (return . Left) case (tbranch', fbranch') of @@ -81,7 +81,7 @@ (Right tbranch'', Left _) -> return $ useBranch tbranch'' (Right tbranch'', Right fbranch'') -> - return $ oneStm $ Let pat aux $ If cond tbranch'' fbranch'' (IfAttr ts IfEquiv) + return $ oneStm $ Let pat aux $ If cond tbranch'' fbranch'' (IfDec ts IfEquiv) (Left e, _) -> throwError e @@ -98,10 +98,10 @@ } nameInfoConv :: NameInfo KernelsMem -> NameInfo KernelsMem -nameInfoConv (LetInfo mem_info) = LetInfo mem_info -nameInfoConv (FParamInfo mem_info) = FParamInfo mem_info -nameInfoConv (LParamInfo mem_info) = LParamInfo mem_info -nameInfoConv (IndexInfo it) = IndexInfo it +nameInfoConv (LetName mem_info) = LetName mem_info +nameInfoConv (FParamName mem_info) = FParamName mem_info +nameInfoConv (LParamName mem_info) = LParamName mem_info +nameInfoConv (IndexName it) = IndexName it transformExp :: Exp KernelsMem -> ExpandM (Stms KernelsMem, Exp KernelsMem) @@ -208,8 +208,6 @@ -- much memory (and which space) is needed. type Extraction = M.Map VName (SubExp, Space) --- | Extract allocations from 'Thread' statements with --- 'extractThreadAllocations'. extractKernelBodyAllocations :: Names -> Names -> KernelBody KernelsMem -> (KernelBody KernelsMem, Extraction) @@ -404,15 +402,15 @@ return kbody { kernelBodyStms = stms' } offsetMemoryInBody :: Body KernelsMem -> OffsetM (Body KernelsMem) -offsetMemoryInBody (Body attr stms res) = do +offsetMemoryInBody (Body dec stms res) = do scope <- askScope stms' <- stmsFromList . snd <$> mapAccumLM (\scope' -> localScope scope' . offsetMemoryInStm) scope (stmsToList stms) - return $ Body attr stms' res + return $ Body dec stms' res offsetMemoryInStm :: Stm KernelsMem -> OffsetM (Scope KernelsMem, Stm KernelsMem) -offsetMemoryInStm (Let pat attr e) = do +offsetMemoryInStm (Let pat dec e) = do pat' <- offsetMemoryInPattern pat e' <- localScope (scopeOfPattern pat') $ offsetMemoryInExp e scope <- askScope @@ -421,7 +419,7 @@ rts <- runReaderT (expReturns e') scope let pat'' = Pattern (patternContextElements pat') (zipWith pick (patternValueElements pat') rts) - stm = Let pat'' attr e' + stm = Let pat'' dec e' let scope' = scopeOf stm <> scope return (scope', stm) where pick :: PatElemT (MemInfo SubExp NoUniqueness MemBind) -> @@ -442,8 +440,8 @@ mapM_ inspectCtx ctx Pattern ctx <$> mapM inspectVal vals where inspectVal patElem = do - new_attr <- offsetMemoryInMemBound $ patElemAttr patElem - return patElem { patElemAttr = new_attr } + new_dec <- offsetMemoryInMemBound $ patElemDec patElem + return patElem { patElemDec = new_dec } inspectCtx patElem | Mem space <- patElemType patElem, expandable space = @@ -454,8 +452,8 @@ offsetMemoryInParam :: Param (MemBound u) -> OffsetM (Param (MemBound u)) offsetMemoryInParam fparam = do - fparam' <- offsetMemoryInMemBound $ paramAttr fparam - return fparam { paramAttr = fparam' } + fparam' <- offsetMemoryInMemBound $ paramDec fparam + return fparam { paramDec = fparam' } offsetMemoryInMemBound :: MemBound u -> OffsetM (MemBound u) offsetMemoryInMemBound summary@(MemArray pt shape u (ArrayIn mem ixfun)) = do @@ -510,11 +508,11 @@ unAllocKernelsStms :: Stms KernelsMem -> Either String (Stms Kernels.Kernels) unAllocKernelsStms = unAllocStms False where - unAllocBody (Body attr stms res) = - Body attr <$> unAllocStms True stms <*> pure res + unAllocBody (Body dec stms res) = + Body dec <$> unAllocStms True stms <*> pure res - unAllocKernelBody (KernelBody attr stms res) = - KernelBody attr <$> unAllocStms True stms <*> pure res + unAllocKernelBody (KernelBody dec stms res) = + KernelBody dec <$> unAllocStms True stms <*> pure res unAllocStms nested = fmap (stmsFromList . catMaybes) . mapM (unAllocStm nested) . stmsToList @@ -522,17 +520,17 @@ unAllocStm nested stm@(Let _ _ (Op Alloc{})) | nested = throwError $ "Cannot handle nested allocation: " ++ pretty stm | otherwise = return Nothing - unAllocStm _ (Let pat attr e) = - Just <$> (Let <$> unAllocPattern pat <*> pure attr <*> mapExpM unAlloc' e) + unAllocStm _ (Let pat dec e) = + Just <$> (Let <$> unAllocPattern pat <*> pure dec <*> mapExpM unAlloc' e) unAllocLambda (Lambda params body ret) = Lambda (unParams params) <$> unAllocBody body <*> pure ret - unParams = mapMaybe $ traverse unAttr + unParams = mapMaybe $ traverse unMem unAllocPattern pat@(Pattern ctx val) = - Pattern <$> maybe bad return (mapM (rephrasePatElem unAttr) ctx) - <*> maybe bad return (mapM (rephrasePatElem unAttr) val) + Pattern <$> maybe bad return (mapM (rephrasePatElem unMem) ctx) + <*> maybe bad return (mapM (rephrasePatElem unMem) val) where bad = Left $ "Cannot handle memory in pattern " ++ pretty pat unAllocOp Alloc{} = Left "unAllocOp: unhandled Alloc" @@ -544,10 +542,10 @@ , mapOnSegOpBody = unAllocKernelBody } - unParam p = maybe bad return $ traverse unAttr p + unParam p = maybe bad return $ traverse unMem p where bad = Left $ "Cannot handle memory-typed parameter '" ++ pretty p ++ "'" - unT t = maybe bad return $ unAttr t + unT t = maybe bad return $ unMem t where bad = Left $ "Cannot handle memory type '" ++ pretty t ++ "'" unAlloc' = Mapper { mapOnBody = const unAllocBody @@ -560,17 +558,17 @@ , mapOnVName = Right } -unAttr :: MemInfo d u ret -> Maybe (TypeBase (ShapeBase d) u) -unAttr (MemPrim pt) = Just $ Prim pt -unAttr (MemArray pt shape u _) = Just $ Array pt shape u -unAttr MemMem{} = Nothing +unMem :: MemInfo d u ret -> Maybe (TypeBase (ShapeBase d) u) +unMem (MemPrim pt) = Just $ Prim pt +unMem (MemArray pt shape u _) = Just $ Array pt shape u +unMem MemMem{} = Nothing unAllocScope :: Scope KernelsMem -> Scope Kernels.Kernels unAllocScope = M.mapMaybe unInfo - where unInfo (LetInfo attr) = LetInfo <$> unAttr attr - unInfo (FParamInfo attr) = FParamInfo <$> unAttr attr - unInfo (LParamInfo attr) = LParamInfo <$> unAttr attr - unInfo (IndexInfo it) = Just $ IndexInfo it + where unInfo (LetName dec) = LetName <$> unMem dec + unInfo (FParamName dec) = FParamName <$> unMem dec + unInfo (LParamName dec) = LParamName <$> unMem dec + unInfo (IndexName it) = Just $ IndexName it removeCommonSizes :: Extraction -> [(SubExp, [(VName, Space)])] @@ -608,7 +606,7 @@ new_inds = unflattenIndex (map (primExpFromSubExp int32) kspace_dims) (primExpFromSubExp int32 $ Var $ paramName flat_gtid_lparam) - zipWithM_ letBindNames_ (map pure kspace_gtids) =<< mapM toExp new_inds + zipWithM_ letBindNames (map pure kspace_gtids) =<< mapM toExp new_inds mapM_ addStm kstms' return sizes diff --git a/src/Futhark/Pass/ExplicitAllocations.hs b/src/Futhark/Pass/ExplicitAllocations.hs --- a/src/Futhark/Pass/ExplicitAllocations.hs +++ b/src/Futhark/Pass/ExplicitAllocations.hs @@ -50,13 +50,11 @@ import Data.Maybe import Data.List (zip4, partition, sort) -import Futhark.Optimise.Simplify.Lore - (mkWiseBody, mkWiseLetStm, removeExpWisdom, removeScopeWisdom) +import Futhark.Optimise.Simplify.Lore (mkWiseBody) import Futhark.MonadFreshNames -import Futhark.Representation.Mem -import qualified Futhark.Representation.Mem.IxFun as IxFun +import Futhark.IR.Mem +import qualified Futhark.IR.Mem.IxFun as IxFun import Futhark.Tools -import qualified Futhark.Analysis.SymbolTable as ST import Futhark.Optimise.Simplify.Engine (SimpleOps (..)) import qualified Futhark.Optimise.Simplify.Engine as Engine import Futhark.Pass @@ -70,11 +68,11 @@ bindAllocStm :: (MonadBinder m, Op (Lore m) ~ MemOp inner) => AllocStm -> m () bindAllocStm (SizeComputation name pe) = - letBindNames_ [name] =<< toExp (coerceIntPrimExp Int64 pe) + letBindNames [name] =<< toExp (coerceIntPrimExp Int64 pe) bindAllocStm (Allocation name size space) = - letBindNames_ [name] $ Op $ Alloc size space + letBindNames [name] $ Op $ Alloc size space bindAllocStm (ArrayCopy name src) = - letBindNames_ [name] $ BasicOp $ Copy src + letBindNames [name] $ BasicOp $ Copy src class (MonadFreshNames m, HasScope lore m, Mem lore) => Allocator lore m where @@ -85,11 +83,11 @@ m ~ AllocM fromlore lore) => AllocStm -> m () addAllocStm (SizeComputation name se) = - letBindNames_ [name] =<< toExp (coerceIntPrimExp Int64 se) + letBindNames [name] =<< toExp (coerceIntPrimExp Int64 se) addAllocStm (Allocation name size space) = - letBindNames_ [name] $ Op $ allocOp size space + letBindNames [name] $ Op $ allocOp size space addAllocStm (ArrayCopy name src) = - letBindNames_ [name] $ BasicOp $ Copy src + letBindNames [name] $ BasicOp $ Copy src -- | The subexpression giving the number of elements we should -- allocate space for. See 'ChunkMap' comment. @@ -127,13 +125,13 @@ type Allocable fromlore tolore = (PrettyLore fromlore, PrettyLore tolore, Mem tolore, - FParamAttr fromlore ~ DeclType, - LParamAttr fromlore ~ Type, + FParamInfo fromlore ~ DeclType, + LParamInfo fromlore ~ Type, BranchType fromlore ~ ExtType, RetType fromlore ~ DeclExtType, - BodyAttr fromlore ~ (), - BodyAttr tolore ~ (), - ExpAttr tolore ~ (), + BodyDec fromlore ~ (), + BodyDec tolore ~ (), + ExpDec tolore ~ (), SizeSubst (Op tolore), BinderOps tolore) @@ -172,7 +170,7 @@ MonadBinder (AllocM fromlore tolore) where type Lore (AllocM fromlore tolore) = tolore - mkExpAttrM _ _ = return () + mkExpDecM _ _ = return () mkLetNamesM names e = do pat <- patternWithAllocations names e @@ -182,7 +180,6 @@ addStms binding = AllocM $ addBinderStms binding collectStms (AllocM m) = AllocM $ collectBinderStms m - certifying cs (AllocM m) = AllocM $ certifyingBinder cs m instance (Allocable fromlore tolore) => Allocator tolore (AllocM fromlore tolore) where @@ -256,7 +253,7 @@ size <- arraySizeInBytes t allocateMemory "mem" size space -allocsForStm :: (Allocator lore m, ExpAttr lore ~ ()) => +allocsForStm :: (Allocator lore m, ExpDec lore ~ ()) => [Ident] -> [Ident] -> Exp lore -> m (Stm lore) allocsForStm sizeidents validents e = do @@ -265,7 +262,7 @@ (ctxElems, valElems) <- allocsForPattern sizeidents validents rts hints return $ Let (Pattern ctxElems valElems) (defAux ()) e -patternWithAllocations :: (Allocator lore m, ExpAttr lore ~ ()) => +patternWithAllocations :: (Allocator lore m, ExpDec lore ~ ()) => [VName] -> Exp lore -> m (Pattern lore) @@ -419,11 +416,11 @@ ixfun = IxFun.iota $ map (primExpFromSubExp int32) $ shapeDims shape mem <- lift $ newVName memname tell [Param mem $ MemMem pspace] - return param { paramAttr = MemArray bt shape u $ ArrayIn mem ixfun } + return param { paramDec = MemArray bt shape u $ ArrayIn mem ixfun } Prim bt -> - return param { paramAttr = MemPrim bt } + return param { paramDec = MemPrim bt } Mem space -> - return param { paramAttr = MemMem space } + return param { paramDec = MemMem space } allocInMergeParams :: (Allocable fromlore tolore, Allocator tolore (AllocM fromlore tolore)) => @@ -455,7 +452,7 @@ reuse && u == Unique && loopInvariantShape mergeparam - then return (mergeparam { paramAttr = MemArray bt shape Unique $ ArrayIn mem ixfun }, + then return (mergeparam { paramDec = MemArray bt shape Unique $ ArrayIn mem ixfun }, lift . ensureArrayIn (paramType mergeparam) mem ixfun) else do def_space <- asks allocSpace doDefault mergeparam def_space @@ -484,7 +481,7 @@ let summary = MemArray (elemType t) (arrayShape t) NoUniqueness $ ArrayIn mem ixfun pat = Pattern [] [PatElem (identName copy) summary] - letBind_ pat $ BasicOp $ Copy v + letBind pat $ BasicOp $ Copy v return $ Var $ identName copy ensureDirectArray :: (Allocable fromlore tolore, @@ -564,10 +561,10 @@ runAllocM handleOp hints $ localScope scope $ allocInStms stms return memoryInDeclExtType :: [DeclExtType] -> [FunReturns] -memoryInDeclExtType ts = evalState (mapM addAttr ts) $ startOfFreeIDRange ts - where addAttr (Prim t) = return $ MemPrim t - addAttr Mem{} = error "memoryInDeclExtType: too much memory" - addAttr (Array bt shape u) = do +memoryInDeclExtType ts = evalState (mapM addMem ts) $ startOfFreeIDRange ts + where addMem (Prim t) = return $ MemPrim t + addMem Mem{} = error "memoryInDeclExtType: too much memory" + addMem (Array bt shape u) = do i <- get <* modify (+1) return $ MemArray bt shape u $ ReturnsNewBlock DefaultSpace i $ IxFun.iota $ map convert $ shapeDims shape @@ -663,7 +660,7 @@ allocInExp (Apply fname args rettype loc) = do args' <- funcallArgs args return $ Apply fname args' (memoryInDeclExtType rettype) loc -allocInExp (If cond tbranch0 fbranch0 (IfAttr rets ifsort)) = do +allocInExp (If cond tbranch0 fbranch0 (IfDec rets ifsort)) = do let num_rets = length rets -- switch to the explicit-mem rep, but do nothing about results (tbranch, tm_ixfs) <- allocInIfBody num_rets tbranch0 @@ -691,7 +688,7 @@ rets'' = foldl (\acc (i, se) -> fixExt i se acc) trets ind_ses tbranch'' = tbranch' { bodyResult = r_then_ext ++ drop size_ext res_then } fbranch'' = fbranch' { bodyResult = r_else_ext ++ drop size_ext res_else } - res_if_expr = If cond tbranch'' fbranch'' $ IfAttr rets'' ifsort + res_if_expr = If cond tbranch'' fbranch'' $ IfDec rets'' ifsort return res_if_expr where generalize :: (Maybe Space, Maybe MemBind) -> (Maybe Space, Maybe MemBind) -> (Maybe Space, Maybe (ExtIxFun, [(PrimExp VName, PrimExp VName)])) @@ -768,9 +765,7 @@ k) Just (ixfn, m) -> do -- generalizes let i = length m - ext_ses <- mapM (primExpToSubExp "ixfn_exist" - (return . BasicOp . SubExp . Var)) - m + ext_ses <- mapM (toSubExp "ixfn_exist") m mem_ctx_r <- bodyReturnMemCtx r let sp' = fromMaybe DefaultSpace sp ixfn' = fmap (adjustExtPE k) ixfn @@ -835,14 +830,14 @@ dims <- map (primExpFromSubExp int32) . arrayDims <$> lookupType a let ixfun' = IxFun.slice ixfun $ fullSliceNum dims [DimFix $ LeafExp i int32] - return (p { paramAttr = MemArray bt shape u $ ArrayIn mem ixfun' }, a) + return (p { paramDec = MemArray bt shape u $ ArrayIn mem ixfun' }, a) Prim bt -> - return (p { paramAttr = MemPrim bt }, a) + return (p { paramDec = MemPrim bt }, a) Mem space -> - return (p { paramAttr = MemMem space }, a) + return (p { paramDec = MemMem space }, a) class SizeSubst op where - opSizeSubst :: PatternT attr -> op -> ChunkMap + opSizeSubst :: PatternT dec -> op -> ChunkMap opIsConst :: op -> Bool opIsConst = const False @@ -866,15 +861,15 @@ stmConsts _ = mempty mkLetNamesB' :: (Op (Lore m) ~ MemOp inner, - MonadBinder m, ExpAttr (Lore m) ~ (), + MonadBinder m, ExpDec (Lore m) ~ (), Allocator (Lore m) (PatAllocM (Lore m))) => - ExpAttr (Lore m) -> [VName] -> Exp (Lore m) -> m (Stm (Lore m)) -mkLetNamesB' attr names e = do + ExpDec (Lore m) -> [VName] -> Exp (Lore m) -> m (Stm (Lore m)) +mkLetNamesB' dec names e = do scope <- askScope pat <- bindPatternWithAllocations scope names e - return $ Let pat (defAux attr) e + return $ Let pat (defAux dec) e -mkLetNamesB'' :: (Op (Lore m) ~ MemOp inner, ExpAttr lore ~ (), +mkLetNamesB'' :: (Op (Lore m) ~ MemOp inner, ExpDec lore ~ (), HasScope (Engine.Wise lore) m, Allocator lore (PatAllocM lore), MonadBinder m, Engine.CanBeWise (Op lore)) => [VName] -> Exp (Engine.Wise lore) @@ -884,35 +879,29 @@ (pat, prestms) <- runPatAllocM (patternWithAllocations names $ Engine.removeExpWisdom e) scope mapM_ bindAllocStm prestms let pat' = Engine.addWisdomToPattern pat e - attr = Engine.mkWiseExpAttr pat' () e - return $ Let pat' (defAux attr) e + dec = Engine.mkWiseExpDec pat' () e + return $ Let pat' (defAux dec) e simplifiable :: (Engine.SimplifiableLore lore, - ExpAttr lore ~ (), - BodyAttr lore ~ (), + ExpDec lore ~ (), + BodyDec lore ~ (), Op lore ~ MemOp inner, Allocator lore (PatAllocM lore)) => (inner -> Engine.SimpleM lore (Engine.OpWithWisdom inner, Stms (Engine.Wise lore))) -> SimpleOps lore simplifiable simplifyInnerOp = - SimpleOps mkExpAttrS' mkBodyS' mkLetNamesS' protectOp simplifyOp - where mkExpAttrS' _ pat e = - return $ Engine.mkWiseExpAttr pat () e + SimpleOps mkExpDecS' mkBodyS' protectOp simplifyOp + where mkExpDecS' _ pat e = + return $ Engine.mkWiseExpDec pat () e mkBodyS' _ bnds res = return $ mkWiseBody () bnds res - mkLetNamesS' vtable names e = do - (pat', stms) <- runBinder $ bindPatternWithAllocations env names $ - removeExpWisdom e - return (mkWiseLetStm pat' (defAux ()) e, stms) - where env = removeScopeWisdom $ ST.toScope vtable - protectOp taken pat (Alloc size space) = Just $ do tbody <- resultBodyM [size] fbody <- resultBodyM [intConst Int64 0] size' <- letSubExp "hoisted_alloc_size" $ - If taken tbody fbody $ IfAttr [MemPrim int64] IfFallback - letBind_ pat $ Op $ Alloc size' space + If taken tbody fbody $ IfDec [MemPrim int64] IfFallback + letBind pat $ Op $ Alloc size' space protectOp _ _ _ = Nothing simplifyOp (Alloc size space) = @@ -921,7 +910,7 @@ return (Inner k', hoisted) bindPatternWithAllocations :: (MonadBinder m, - ExpAttr lore ~ (), + ExpDec lore ~ (), Op (Lore m) ~ MemOp inner, Allocator lore (PatAllocM lore)) => Scope lore -> [VName] -> Exp lore @@ -934,5 +923,5 @@ data ExpHint = NoHint | Hint IxFun Space -defaultExpHints :: (Monad m, Attributes lore) => Exp lore -> m [ExpHint] +defaultExpHints :: (Monad m, ASTLore lore) => Exp lore -> m [ExpHint] defaultExpHints e = return $ replicate (expExtTypeSize e) NoHint diff --git a/src/Futhark/Pass/ExplicitAllocations/Kernels.hs b/src/Futhark/Pass/ExplicitAllocations/Kernels.hs --- a/src/Futhark/Pass/ExplicitAllocations/Kernels.hs +++ b/src/Futhark/Pass/ExplicitAllocations/Kernels.hs @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} +-- | Facilities for converting a 'Kernels' program to 'KernelsMem'. module Futhark.Pass.ExplicitAllocations.Kernels ( explicitAllocations , explicitAllocationsInStms @@ -11,9 +12,9 @@ import qualified Data.Map as M import qualified Data.Set as S -import qualified Futhark.Representation.Mem.IxFun as IxFun -import Futhark.Representation.KernelsMem -import Futhark.Representation.Kernels +import qualified Futhark.IR.Mem.IxFun as IxFun +import Futhark.IR.KernelsMem +import Futhark.IR.Kernels import Futhark.Pass.ExplicitAllocations import Futhark.Pass.ExplicitAllocations.SegOp @@ -161,9 +162,11 @@ semiStatic _ Constant{} = True semiStatic consts (Var v) = v `S.member` consts +-- | The pass from 'Kernels' to 'KernelsMem'. explicitAllocations :: Pass Kernels KernelsMem explicitAllocations = explicitAllocationsGeneric handleHostOp kernelExpHints +-- | Convert some 'Kernels' stms to 'KernelsMem'. explicitAllocationsInStms :: (MonadFreshNames m, HasScope KernelsMem m) => Stms Kernels -> m (Stms KernelsMem) explicitAllocationsInStms = explicitAllocationsInStmsGeneric handleHostOp kernelExpHints diff --git a/src/Futhark/Pass/ExplicitAllocations/SegOp.hs b/src/Futhark/Pass/ExplicitAllocations/SegOp.hs --- a/src/Futhark/Pass/ExplicitAllocations/SegOp.hs +++ b/src/Futhark/Pass/ExplicitAllocations/SegOp.hs @@ -7,8 +7,8 @@ ) where -import qualified Futhark.Representation.Mem.IxFun as IxFun -import Futhark.Representation.KernelsMem +import qualified Futhark.IR.Mem.IxFun as IxFun +import Futhark.IR.KernelsMem import Futhark.Pass.ExplicitAllocations allocInKernelBody :: Allocable fromlore tolore => @@ -49,14 +49,14 @@ fullSliceNum base_dims [DimFix my_id] ixfun_y = IxFun.slice ixfun_base $ fullSliceNum base_dims [DimFix other_id] - return (x { paramAttr = MemArray bt shape u $ ArrayIn mem ixfun_x }, - y { paramAttr = MemArray bt shape u $ ArrayIn mem ixfun_y }) + return (x { paramDec = MemArray bt shape u $ ArrayIn mem ixfun_x }, + y { paramDec = MemArray bt shape u $ ArrayIn mem ixfun_y }) Prim bt -> - return (x { paramAttr = MemPrim bt }, - y { paramAttr = MemPrim bt }) + return (x { paramDec = MemPrim bt }, + y { paramDec = MemPrim bt }) Mem space -> - return (x { paramAttr = MemMem space }, - y { paramAttr = MemMem space }) + return (x { paramDec = MemMem space }, + y { paramDec = MemMem space }) allocInBinOpLambda :: Allocable fromlore tolore => SubExp -> SegSpace -> Lambda fromlore diff --git a/src/Futhark/Pass/ExplicitAllocations/Seq.hs b/src/Futhark/Pass/ExplicitAllocations/Seq.hs --- a/src/Futhark/Pass/ExplicitAllocations/Seq.hs +++ b/src/Futhark/Pass/ExplicitAllocations/Seq.hs @@ -8,8 +8,8 @@ where import Futhark.Pass -import Futhark.Representation.SeqMem -import Futhark.Representation.Seq +import Futhark.IR.SeqMem +import Futhark.IR.Seq import Futhark.Pass.ExplicitAllocations explicitAllocations :: Pass Seq SeqMem diff --git a/src/Futhark/Pass/ExtractKernels.hs b/src/Futhark/Pass/ExtractKernels.hs --- a/src/Futhark/Pass/ExtractKernels.hs +++ b/src/Futhark/Pass/ExtractKernels.hs @@ -6,6 +6,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings #-} -- | Kernel extraction. -- -- In the following, I will use the term "width" to denote the amount @@ -166,10 +167,10 @@ import Prelude hiding (log) -import Futhark.Representation.SOACS -import Futhark.Representation.SOACS.Simplify (simplifyStms) -import qualified Futhark.Representation.Kernels as Out -import Futhark.Representation.Kernels.Kernel +import Futhark.IR.SOACS +import Futhark.IR.SOACS.Simplify (simplifyStms) +import qualified Futhark.IR.Kernels as Out +import Futhark.IR.Kernels.Kernel import Futhark.MonadFreshNames import Futhark.Tools import qualified Futhark.Transform.FirstOrderTransform as FOT @@ -312,7 +313,7 @@ kernelAlternatives pat default_body [] = runBinder_ $ do ses <- bodyBind default_body forM_ (zip (patternNames pat) ses) $ \(name, se) -> - letBindNames_ [name] $ BasicOp $ SubExp se + letBindNames [name] $ BasicOp $ SubExp se kernelAlternatives pat default_body ((cond,alt):alts) = runBinder_ $ do alts_pat <- fmap (Pattern []) $ forM (patternElements pat) $ \pe -> do name <- newVName $ baseString $ patElemName pe @@ -321,11 +322,20 @@ alt_stms <- kernelAlternatives alts_pat default_body alts let alt_body = mkBody alt_stms $ map Var $ patternValueNames alts_pat - letBind_ pat $ If cond alt alt_body $ - IfAttr (staticShapes (patternTypes pat)) IfEquiv + letBind pat $ If cond alt alt_body $ + IfDec (staticShapes (patternTypes pat)) IfEquiv transformStm :: KernelPath -> Stm -> DistribM KernelsStms +transformStm _ stm + | "sequential" `inAttrs` stmAuxAttrs (stmAux stm) = + runBinder_ $ FOT.transformStmRecursively stm + +transformStm path (Let pat aux (Op soac)) + | "sequential_outer" `inAttrs` stmAuxAttrs aux = + transformStms path . stmsToList . fmap (certify (stmAuxCerts aux)) =<< + runBinder_ (FOT.transformSOAC pat soac) + transformStm path (Let pat aux (If c tb fb rt)) = do tb' <- transformBody path tb fb' <- transformBody path fb @@ -342,11 +352,11 @@ ForLoop i it bound ps -> ForLoop i it bound ps -transformStm path (Let pat (StmAux cs _) (Op (Screma w form arrs))) +transformStm path (Let pat aux (Op (Screma w form arrs))) | Just lam <- isMapSOAC form = - onMap path $ MapLoop pat cs w lam arrs + onMap path $ MapLoop pat aux w lam arrs -transformStm path (Let res_pat (StmAux cs _) (Op (Screma w form arrs))) +transformStm path (Let res_pat (StmAux cs _ _) (Op (Screma w form arrs))) | Just scans <- isScanSOAC form, Scan scan_lam nes <- singleScan scans, Just do_iswim <- iswim res_pat w scan_lam $ zip nes arrs = do @@ -383,7 +393,7 @@ lvl <- segThreadCapped [w] "segscan" $ NoRecommendation SegNoVirt addStms =<< segScan lvl res_pat w scan_ops map_lam' arrs [] [] -transformStm path (Let res_pat (StmAux cs _) (Op (Screma w form arrs))) +transformStm path (Let res_pat (StmAux cs _ _) (Op (Screma w form arrs))) | Just [Reduce comm red_fun nes] <- isReduceSOAC form, let comm' | commutativeLambda red_fun = Commutative | otherwise = comm, @@ -392,7 +402,7 @@ (_, bnds) <- fst <$> runBinderT (simplifyStms =<< collectStms_ (certifying cs do_irwim)) types transformStms path $ stmsToList bnds -transformStm path (Let pat (StmAux cs _) (Op (Screma w form arrs))) +transformStm path (Let pat aux@(StmAux cs _ _) (Op (Screma w form arrs))) | Just (reds, map_lam) <- isRedomapSOAC form = do let paralleliseOuter = runBinder_ $ do @@ -423,7 +433,8 @@ renameBody =<< (mkBody <$> paralleliseInner path' <*> pure (map Var (patternNames pat))) - if not $ lambdaContainsParallelism map_lam + if not (lambdaContainsParallelism map_lam) || + "sequential_inner" `inAttrs` stmAuxAttrs aux then paralleliseOuter else if incrementalFlattening then do ((outer_suff, outer_suff_key), suff_stms) <- @@ -437,22 +448,25 @@ -- Streams can be handled in two different ways - either we -- sequentialise the body or we keep it parallel and distribute. -transformStm path (Let pat (StmAux cs _) (Op (Stream w (Parallel _ _ _ []) map_fun arrs))) = do +transformStm path (Let pat aux@(StmAux cs _ _) (Op (Stream w (Parallel _ _ _ []) map_fun arrs))) + | not ("sequential_inner" `inAttrs` stmAuxAttrs aux) = do -- No reduction part. Remove the stream and leave the body -- parallel. It will be distributed. types <- asksScope scopeForSOACs transformStms path =<< (stmsToList . snd <$> runBinderT (certifying cs $ sequentialStreamWholeArray pat w [] map_fun arrs) types) -transformStm path (Let pat aux@(StmAux cs _) (Op (Stream w (Parallel o comm red_fun nes) fold_fun arrs))) - | incrementalFlattening = do +transformStm path (Let pat aux@(StmAux cs _ _) (Op (Stream w (Parallel o comm red_fun nes) fold_fun arrs))) + | incrementalFlattening, + not ("sequential_inner" `inAttrs` stmAuxAttrs aux) = do ((outer_suff, outer_suff_key), suff_stms) <- sufficientParallelism "suff_outer_stream" [w] path outer_stms <- outerParallelBody ((outer_suff_key, True) : path) inner_stms <- innerParallelBody ((outer_suff_key, False) : path) - (suff_stms<>) <$> kernelAlternatives pat inner_stms [(outer_suff, outer_stms)] + (suff_stms<>) <$> + kernelAlternatives pat inner_stms [(outer_suff, outer_stms)] | otherwise = paralleliseOuter path @@ -502,7 +516,7 @@ comm' | commutativeLambda red_fun, o /= InOrder = Commutative | otherwise = comm -transformStm path (Let pat (StmAux cs _) (Op (Screma w form arrs))) = do +transformStm path (Let pat (StmAux cs _ _) (Op (Screma w form arrs))) = do -- This screma is too complicated for us to immediately do -- anything, so split it up and try again. scope <- asksScope scopeForSOACs @@ -517,14 +531,14 @@ (stmsToList . snd <$> runBinderT (sequentialStreamWholeArray pat w nes fold_fun arrs) types) -transformStm _ (Let pat (StmAux cs _) (Op (Scatter w lam ivs as))) = runBinder_ $ do +transformStm _ (Let pat (StmAux cs _ _) (Op (Scatter w lam ivs as))) = runBinder_ $ do let lam' = soacsLambdaToKernels lam write_i <- newVName "write_i" let (as_ws, as_ns, as_vs) = unzip3 as (i_res, v_res) = splitAt (sum as_ns) $ bodyResult $ lambdaBody lam' kstms = bodyStms $ lambdaBody lam' krets = do (a_w, a, is_vs) <- zip3 as_ws as_vs $ chunks as_ns $ zip i_res v_res - return $ WriteReturns [a_w] a [ ([i],v) | (i,v) <- is_vs ] + return $ WriteReturns [a_w] a [ ([DimFix i],v) | (i,v) <- is_vs ] body = KernelBody () kstms krets inputs = do (p, p_a) <- zip (lambdaParams lam') ivs return $ KernelInput (paramName p) (paramType p) p_a [Var write_i] @@ -532,9 +546,9 @@ mapKernel segThreadCapped [(write_i,w)] inputs (map rowType $ patternTypes pat) body certifying cs $ do addStms stms - letBind_ pat $ Op $ SegOp kernel + letBind pat $ Op $ SegOp kernel -transformStm _ (Let orig_pat (StmAux cs _) (Op (Hist w ops bucket_fun imgs))) = do +transformStm _ (Let orig_pat (StmAux cs _ _) (Op (Hist w ops bucket_fun imgs))) = do let bfun' = soacsLambdaToKernels bucket_fun -- It is important not to launch unnecessarily many threads for @@ -602,9 +616,9 @@ lift $ localScope scope $ transformStms path $ stmsToList stms onMap :: KernelPath -> MapLoop -> DistribM KernelsStms -onMap path (MapLoop pat cs w lam arrs) = do +onMap path (MapLoop pat aux w lam arrs) = do types <- askScope - let loopnest = MapNesting pat cs w $ zip (lambdaParams lam) arrs + let loopnest = MapNesting pat aux w $ zip (lambdaParams lam) arrs env path' = DistEnv { distNest = singleNesting (Nesting mempty loopnest) , distScope = scopeOfPattern pat <> @@ -620,7 +634,9 @@ runDistNestT (env path') $ distributeMapBodyStms acc (bodyStms $ lambdaBody lam) - if not incrementalFlattening then exploitInnerParallelism path + if not incrementalFlattening && + not ("sequential_inner" `inAttrs` stmAuxAttrs aux) + then exploitInnerParallelism path else do let exploitOuterParallelism path' = do @@ -633,6 +649,18 @@ , distStms = mempty } +mayExploitOuter :: Attrs -> Bool +mayExploitOuter attrs = + not $ + "incremental_flattening_no_outer" `inAttrs` attrs || + "incremental_flattening_only_inner" `inAttrs` attrs + +mayExploitIntra :: Attrs -> Bool +mayExploitIntra attrs = + not $ + "incremental_flattening_no_intra" `inAttrs` attrs || + "incremental_flattening_only_inner" `inAttrs` attrs + onMap' :: KernelNest -> KernelPath -> (KernelPath -> DistribM (Out.Stms Out.Kernels)) -> (KernelPath -> DistribM (Out.Stms Out.Kernels)) @@ -642,24 +670,29 @@ onMap' loopnest path mk_seq_stms mk_par_stms pat lam = do let nest_ws = kernelNestWidths loopnest res = map Var $ patternNames pat + aux = loopNestingAux $ innermostKernelNesting loopnest types <- askScope ((outer_suff, outer_suff_key), outer_suff_stms) <- sufficientParallelism "suff_outer_par" nest_ws path - intra <- if worthIntraGroup lam then + intra <- if worthIntraGroup lam && mayExploitIntra (stmAuxAttrs aux) then flip runReaderT types $ intraGroupParallelise loopnest lam else return Nothing seq_body <- renameBody =<< mkBody <$> mk_seq_stms ((outer_suff_key, True) : path) <*> pure res - let seq_alts = [(outer_suff, seq_body) | worthSequentialising lam] + let seq_alts = [(outer_suff, seq_body) + | worthSequentialising lam, + mayExploitOuter $ stmAuxAttrs aux] case intra of Nothing -> do par_body <- renameBody =<< mkBody <$> mk_par_stms ((outer_suff_key, False) : path) <*> pure res - (outer_suff_stms<>) <$> kernelAlternatives pat par_body seq_alts + if "sequential_inner" `inAttrs` stmAuxAttrs aux + then kernelAlternatives pat seq_body [] + else (outer_suff_stms<>) <$> kernelAlternatives pat par_body seq_alts Just ((_intra_min_par, intra_avail_par), group_size, log, intra_prelude, intra_stms) -> do addLog log @@ -691,15 +724,17 @@ (intra_suff_key, False)] ++ path) <*> pure res - ((outer_suff_stms<>intra_suff_stms)<>) <$> - kernelAlternatives pat par_body (seq_alts ++ [(intra_ok, group_par_body)]) + if "sequential_inner" `inAttrs` stmAuxAttrs aux + then kernelAlternatives pat seq_body [] + else ((outer_suff_stms<>intra_suff_stms)<>) <$> + kernelAlternatives pat par_body (seq_alts ++ [(intra_ok, group_par_body)]) onInnerMap :: KernelPath -> MapLoop -> DistAcc Out.Kernels -> DistNestT Out.Kernels DistribM (DistAcc Out.Kernels) -onInnerMap path maploop@(MapLoop pat cs w lam arrs) acc +onInnerMap path maploop@(MapLoop pat aux w lam arrs) acc | unbalancedLambda lam, lambdaContainsParallelism lam = addStmToAcc (mapLoopStm maploop) acc - | not incrementalFlattening = + | not incrementalFlattening, not $ "sequential_inner" `inAttrs` stmAuxAttrs aux = distributeMap maploop acc | otherwise = distributeSingleStm acc (mapLoopStm maploop) >>= \case @@ -723,7 +758,7 @@ scope <- (extra_scope<>) <$> askScope stms <- lift $ localScope scope $ do - let maploop' = MapLoop pat cs w lam arrs + let maploop' = MapLoop pat aux w lam arrs exploitInnerParallelism path' = do let dist_env' = @@ -739,7 +774,7 @@ -- order instead. let lam_res' = rearrangeShape perm $ bodyResult $ lambdaBody lam lam' = lam { lambdaBody = (lambdaBody lam) { bodyResult = lam_res' } } - map_nesting = MapNesting pat cs w $ zip (lambdaParams lam) arrs + map_nesting = MapNesting pat aux w $ zip (lambdaParams lam) arrs nest' = pushInnerKernelNesting (pat, lam_res') map_nesting nest -- XXX: we do not construct a new KernelPath when diff --git a/src/Futhark/Pass/ExtractKernels/BlockedKernel.hs b/src/Futhark/Pass/ExtractKernels/BlockedKernel.hs --- a/src/Futhark/Pass/ExtractKernels/BlockedKernel.hs +++ b/src/Futhark/Pass/ExtractKernels/BlockedKernel.hs @@ -27,8 +27,8 @@ import Prelude hiding (quot) import Futhark.Analysis.PrimExp -import Futhark.Representation.AST -import Futhark.Representation.SegOp +import Futhark.IR +import Futhark.IR.SegOp import Futhark.MonadFreshNames import Futhark.Tools import Futhark.Transform.Rename @@ -37,9 +37,9 @@ type DistLore lore = (Bindable lore, HasSegOp lore, BinderOps lore, - LetAttr lore ~ Type, - ExpAttr lore ~ (), - BodyAttr lore ~ ()) + LetDec lore ~ Type, + ExpDec lore ~ (), + BodyDec lore ~ ()) data ThreadRecommendation = ManyThreads | NoRecommendation SegVirt @@ -62,7 +62,7 @@ mapM_ readKernelInput inps forM_ (zip (lambdaParams map_lam) arrs) $ \(p, arr) -> do arr_t <- lookupType arr - letBindNames_ [paramName p] $ + letBindNames [paramName p] $ BasicOp $ Index arr $ fullSlice arr_t [DimFix $ Var gtid] map (Returns ResultMaySimplify) <$> bodyBind (lambdaBody map_lam) @@ -80,7 +80,7 @@ -> m (Stms lore) segRed lvl pat w ops map_lam arrs ispace inps = runBinder_ $ do (kspace, kbody) <- prepareRedOrScan w map_lam arrs ispace inps - letBind_ pat $ Op $ segOp $ + letBind pat $ Op $ segOp $ SegRed lvl kspace ops (lambdaReturnType map_lam) kbody segScan :: (MonadFreshNames m, DistLore lore, HasScope lore m) => @@ -94,7 +94,7 @@ -> m (Stms lore) segScan lvl pat w ops map_lam arrs ispace inps = runBinder_ $ do (kspace, kbody) <- prepareRedOrScan w map_lam arrs ispace inps - letBind_ pat $ Op $ segOp $ + letBind pat $ Op $ segOp $ SegScan lvl kspace ops (lambdaReturnType map_lam) kbody segMap :: (MonadFreshNames m, DistLore lore, HasScope lore m) => @@ -108,7 +108,7 @@ -> m (Stms lore) segMap lvl pat w map_lam arrs ispace inps = runBinder_ $ do (kspace, kbody) <- prepareRedOrScan w map_lam arrs ispace inps - letBind_ pat $ Op $ segOp $ + letBind pat $ Op $ segOp $ SegMap lvl kspace (lambdaReturnType map_lam) kbody dummyDim :: (MonadFreshNames m, MonadBinder m, DistLore (Lore m)) => @@ -129,7 +129,7 @@ return (pat', ispace, forM_ (zip (patternNames pat') (patternNames pat)) $ \(from, to) -> do from_t <- lookupType from - letBindNames_ [to] $ BasicOp $ Index from $ + letBindNames [to] $ BasicOp $ Index from $ fullSlice from_t [DimFix $ intConst Int32 0]) nonSegRed :: (MonadFreshNames m, DistLore lore, HasScope lore m) => @@ -163,11 +163,11 @@ mapM_ readKernelInput inps forM_ (zip (lambdaParams lam) arrs) $ \(p, arr) -> do arr_t <- lookupType arr - letBindNames_ [paramName p] $ + letBindNames [paramName p] $ BasicOp $ Index arr $ fullSlice arr_t [DimFix $ Var gtid] map (Returns ResultMaySimplify) <$> bodyBind (lambdaBody lam) - letBind_ pat $ Op $ segOp $ SegHist lvl space ops (lambdaReturnType lam) kbody + letBind pat $ Op $ segOp $ SegHist lvl space ops (lambdaReturnType lam) kbody mapKernelSkeleton :: (DistLore lore, HasScope lore m, MonadFreshNames m) => [(VName, SubExp)] -> [KernelInput] @@ -211,6 +211,6 @@ readKernelInput inp = do let pe = PatElem (kernelInputName inp) $ kernelInputType inp arr_t <- lookupType $ kernelInputArray inp - letBind_ (Pattern [] [pe]) $ + letBind (Pattern [] [pe]) $ BasicOp $ Index (kernelInputArray inp) $ fullSlice arr_t $ map DimFix $ kernelInputIndices inp diff --git a/src/Futhark/Pass/ExtractKernels/DistributeNests.hs b/src/Futhark/Pass/ExtractKernels/DistributeNests.hs --- a/src/Futhark/Pass/ExtractKernels/DistributeNests.hs +++ b/src/Futhark/Pass/ExtractKernels/DistributeNests.hs @@ -6,6 +6,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings #-} module Futhark.Pass.ExtractKernels.DistributeNests ( MapLoop(..) , mapLoopStm @@ -44,16 +45,17 @@ import Data.Maybe import Data.List (find, partition, tails) -import Futhark.Representation.AST -import qualified Futhark.Representation.SOACS as SOACS -import Futhark.Representation.SOACS.SOAC hiding (HistOp, histDest) -import Futhark.Representation.SOACS (SOACS) -import Futhark.Representation.SOACS.Simplify (simpleSOACS) -import Futhark.Representation.SegOp +import Futhark.IR +import qualified Futhark.IR.SOACS as SOACS +import Futhark.IR.SOACS.SOAC hiding (HistOp, histDest) +import Futhark.IR.SOACS (SOACS) +import Futhark.IR.SOACS.Simplify (simpleSOACS) +import Futhark.IR.SegOp import Futhark.MonadFreshNames import Futhark.Tools import Futhark.Transform.Rename import Futhark.Transform.CopyPropagate +import qualified Futhark.Transform.FirstOrderTransform as FOT import Futhark.Pass.ExtractKernels.Distribution import Futhark.Pass.ExtractKernels.ISRWIM import Futhark.Pass.ExtractKernels.BlockedKernel @@ -64,10 +66,11 @@ scopeForSOACs :: SameScope lore SOACS => Scope lore -> Scope SOACS scopeForSOACs = castScope -data MapLoop = MapLoop SOACS.Pattern Certificates SubExp SOACS.Lambda [VName] +data MapLoop = MapLoop SOACS.Pattern (StmAux ()) SubExp SOACS.Lambda [VName] mapLoopStm :: MapLoop -> Stm SOACS -mapLoopStm (MapLoop pat cs w lam arrs) = Let pat (StmAux cs ()) $ Op $ Screma w (mapSOAC lam) arrs +mapLoopStm (MapLoop pat aux w lam arrs) = + Let pat aux $ Op $ Screma w (mapSOAC lam) arrs data DistEnv lore m = DistEnv { distNest :: Nestings @@ -139,10 +142,10 @@ getNameSource = DistNestT $ lift getNameSource putNameSource = DistNestT . lift . putNameSource -instance (Monad m, Attributes lore) => HasScope lore (DistNestT lore m) where +instance (Monad m, ASTLore lore) => HasScope lore (DistNestT lore m) where askScope = asks distScope -instance (Monad m, Attributes lore) => LocalScope lore (DistNestT lore m) where +instance (Monad m, ASTLore lore) => LocalScope lore (DistNestT lore m) where localScope types = local $ \env -> env { distScope = types <> distScope env } @@ -193,15 +196,15 @@ where provided = namesFromList $ patternNames $ stmPattern stm mapNesting :: (Monad m, DistLore lore) => - PatternT Type -> Certificates -> SubExp -> Lambda SOACS -> [VName] + PatternT Type -> StmAux () -> SubExp -> Lambda SOACS -> [VName] -> DistNestT lore m a -> DistNestT lore m a -mapNesting pat cs w lam arrs = local $ \env -> +mapNesting pat aux w lam arrs = local $ \env -> env { distNest = pushInnerNesting nest $ distNest env , distScope = castScope (scopeOf lam) <> distScope env } where nest = Nesting mempty $ - MapNesting pat cs w $ + MapNesting pat aux w $ zip (lambdaParams lam) arrs inNesting :: (Monad m, DistLore lore) => @@ -243,7 +246,7 @@ where onStms acc [] = return acc - onStms acc (Let pat (StmAux cs _) (Op (Stream w (Sequential accs) lam arrs)):stms) = do + onStms acc (Let pat (StmAux cs _ _) (Op (Stream w (Sequential accs) lam arrs)):stms) = do types <- asksScope scopeForSOACs stream_stms <- snd <$> runBinderT (sequentialStreamWholeArray pat w accs lam arrs) types @@ -271,13 +274,22 @@ Stm SOACS -> DistAcc lore -> DistNestT lore m (DistAcc lore) -maybeDistributeStm bnd@(Let pat _ (Op (Screma w form arrs))) acc +maybeDistributeStm stm acc + | "sequential" `inAttrs` stmAuxAttrs (stmAux stm) = + addStmToAcc stm acc + +maybeDistributeStm (Let pat aux (Op soac)) acc + | "sequential_outer" `inAttrs` stmAuxAttrs aux = + distributeMapBodyStms acc . fmap (certify (stmAuxCerts aux)) =<< + runBinder_ (FOT.transformSOAC pat soac) + +maybeDistributeStm stm@(Let pat _ (Op (Screma w form arrs))) acc | Just lam <- isMapSOAC form = -- Only distribute inside the map if we can distribute everything -- following the map. distributeIfPossible acc >>= \case - Nothing -> addStmToAcc bnd acc - Just acc' -> distribute =<< onInnerMap (MapLoop pat (stmCerts bnd) w lam arrs) acc' + Nothing -> addStmToAcc stm acc + Just acc' -> distribute =<< onInnerMap (MapLoop pat (stmAux stm) w lam arrs) acc' maybeDistributeStm bnd@(Let pat _ (DoLoop [] val form@ForLoop{} body)) acc | null (patternContextElements pat), bodyContainsParallelism body = @@ -321,15 +333,15 @@ _ -> addStmToAcc stm acc -maybeDistributeStm (Let pat (StmAux cs _) (Op (Screma w form arrs))) acc +maybeDistributeStm (Let pat aux (Op (Screma w form arrs))) acc | Just [Reduce comm lam nes] <- isReduceSOAC form, Just m <- irwim pat w comm lam $ zip nes arrs = do types <- asksScope scopeForSOACs - (_, bnds) <- runBinderT (certifying cs m) types + (_, bnds) <- runBinderT (auxing aux m) types distributeMapBodyStms acc bnds -- Parallelise segmented scatters. -maybeDistributeStm bnd@(Let pat (StmAux cs _) (Op (Scatter w lam ivs as))) acc = +maybeDistributeStm bnd@(Let pat (StmAux cs _ _) (Op (Scatter w lam ivs as))) acc = distributeSingleStm acc bnd >>= \case Just (kernels, res, nest, acc') | Just (perm, pat_unused) <- permutationAndMissing pat res -> @@ -343,7 +355,7 @@ addStmToAcc bnd acc -- Parallelise segmented Hist. -maybeDistributeStm bnd@(Let pat (StmAux cs _) (Op (Hist w ops lam as))) acc = +maybeDistributeStm bnd@(Let pat (StmAux cs _ _) (Op (Hist w ops lam as))) acc = distributeSingleStm acc bnd >>= \case Just (kernels, res, nest, acc') | Just (perm, pat_unused) <- permutationAndMissing pat res -> @@ -361,7 +373,7 @@ -- -- If the scan cannot be distributed by itself, it will be -- sequentialised in the default case for this function. -maybeDistributeStm bnd@(Let pat (StmAux cs _) (Op (Screma w form arrs))) acc +maybeDistributeStm bnd@(Let pat (StmAux cs _ _) (Op (Screma w form arrs))) acc | Just (scans, map_lam) <- isScanomapSOAC form, Scan lam nes <- singleScan scans = distributeSingleStm acc bnd >>= \case @@ -384,7 +396,7 @@ -- -- If the reduction cannot be distributed by itself, it will be -- sequentialised in the default case for this function. -maybeDistributeStm bnd@(Let pat (StmAux cs _) (Op (Screma w form arrs))) acc +maybeDistributeStm bnd@(Let pat (StmAux cs _ _) (Op (Screma w form arrs))) acc | Just (reds, map_lam) <- isRedomapSOAC form, Reduce comm lam nes <- singleReduce reds, isIdentityLambda map_lam || incrementalFlattening = @@ -407,7 +419,7 @@ _ -> addStmToAcc bnd acc -maybeDistributeStm (Let pat (StmAux cs _) (Op (Screma w form arrs))) acc +maybeDistributeStm (Let pat (StmAux cs _ _) (Op (Screma w form arrs))) acc | incrementalFlattening || isNothing (isRedomapSOAC form) = do -- This with-loop is too complicated for us to immediately do -- anything, so split it up and try again. @@ -633,8 +645,10 @@ -- First, pretend that the scatter is also part of the nesting. The -- KernelNest we produce here is technically not sensible, but it's -- good enough for flatKernel to work. - let nest' = pushInnerKernelNesting (scatter_pat, bodyResult $ lambdaBody lam) - (MapNesting scatter_pat cs scatter_w $ zip (lambdaParams lam) ivs) nest + let nesting = + MapNesting scatter_pat (StmAux cs mempty ()) scatter_w $ zip (lambdaParams lam) ivs + nest' = + pushInnerKernelNesting (scatter_pat, bodyResult $ lambdaBody lam) nesting nest (ispace, kernel_inps) <- flatKernel nest' let (as_ws, as_ns, as) = unzip3 dests @@ -670,14 +684,14 @@ let pat = Pattern [] $ rearrangeShape perm $ patternValueElements $ loopNestingPattern $ fst nest - letBind_ pat $ Op $ segOp k + letBind pat $ Op $ segOp k where findInput kernel_inps a = maybe bad return $ find ((==a) . kernelInputName) kernel_inps bad = error "Ill-typed nested scatter encountered." inPlaceReturn ispace (aw, inp, is_vs) = WriteReturns (init ws++[aw]) (kernelInputArray inp) - [ (map Var (init gtids)++[i], v) | (i,v) <- is_vs ] + [ (map DimFix $ map Var (init gtids)++[i], v) | (i,v) <- is_vs ] where (gtids,ws) = unzip ispace segmentedUpdateKernel :: (MonadFreshNames m, DistLore lore) => @@ -701,7 +715,7 @@ v' <- certifying cs $ letSubExp "v" $ BasicOp $ Index v $ map (DimFix . Var) slice_gtids let pexp = primExpFromSubExp int32 - slice_is <- traverse (letSubExp "index" <=< toExp) $ + slice_is <- traverse (toSubExp "index") $ fixSlice (map (fmap pexp) slice) $ map (pexp . Var) slice_gtids let write_is = map (Var . fst) base_ispace ++ slice_is @@ -710,7 +724,7 @@ arr_t <- lookupType arr' v_t <- subExpType v' return (v_t, - WriteReturns (arrayDims arr_t) arr' [(write_is, v')]) + WriteReturns (arrayDims arr_t) arr' [(map DimFix write_is, v')]) mk_lvl <- mkSegLevel (k, prestms) <- mapKernel mk_lvl ispace kernel_inps [res_t] $ @@ -722,7 +736,7 @@ let pat = Pattern [] $ rearrangeShape perm $ patternValueElements $ loopNestingPattern $ fst nest - letBind_ pat $ Op $ segOp k + letBind pat $ Op $ segOp k segmentedHistKernel :: (MonadFreshNames m, DistLore lore) => KernelNest @@ -970,7 +984,7 @@ expandPatElemWith dims pe = do name <- newVName $ baseString $ patElemName pe return pe { patElemName = name - , patElemAttr = patElemType pe `arrayOfShape` Shape dims + , patElemDec = patElemType pe `arrayOfShape` Shape dims } kernelOrNot :: (MonadFreshNames m, DistLore lore) => @@ -987,10 +1001,10 @@ distributeMap :: (MonadFreshNames m, DistLore lore) => MapLoop -> DistAcc lore -> DistNestT lore m (DistAcc lore) -distributeMap (MapLoop pat cs w lam arrs) acc = +distributeMap (MapLoop pat aux w lam arrs) acc = distribute =<< leavingNesting =<< - mapNesting pat cs w lam arrs + mapNesting pat aux w lam arrs (distribute =<< distributeMapBodyStms acc' lam_bnds) where acc' = DistAcc { distTargets = pushInnerTarget diff --git a/src/Futhark/Pass/ExtractKernels/Distribution.hs b/src/Futhark/Pass/ExtractKernels/Distribution.hs --- a/src/Futhark/Pass/ExtractKernels/Distribution.hs +++ b/src/Futhark/Pass/ExtractKernels/Distribution.hs @@ -31,6 +31,7 @@ , KernelNest , ppKernelNest , newKernel + , innermostKernelNesting , pushKernelNesting , pushInnerKernelNesting , kernelNestLoops @@ -52,8 +53,8 @@ import Data.Maybe import Data.List (elemIndex, sortOn) -import Futhark.Representation.AST -import Futhark.Representation.SegOp +import Futhark.IR +import Futhark.IR.SegOp import Futhark.MonadFreshNames import Futhark.Tools import Futhark.Util @@ -114,7 +115,7 @@ targetsScope (Targets t ts) = mconcat $ map targetScope $ t : ts data LoopNesting = MapNesting { loopNestingPattern :: PatternT Type - , loopNestingCertificates :: Certificates + , loopNestingAux :: StmAux () , loopNestingWidth :: SubExp , loopNestingParamsAndArrs :: [(Param Type, VName)] } @@ -133,9 +134,9 @@ loopNestingParams = map fst . loopNestingParamsAndArrs instance FreeIn LoopNesting where - freeIn' (MapNesting pat cs w params_and_arrs) = + freeIn' (MapNesting pat aux w params_and_arrs) = freeIn' pat <> - freeIn' cs <> + freeIn' aux <> freeIn' w <> freeIn' params_and_arrs @@ -185,6 +186,11 @@ ppKernelNest (nesting, nestings) = unlines $ map ppLoopNesting $ nesting : nestings +-- | Retrieve the innermost kernel nesting. +innermostKernelNesting :: KernelNest -> LoopNesting +innermostKernelNesting (nest, nests) = + fromMaybe nest $ maybeHead $ reverse nests + -- | Add new outermost nesting, pushing the current outermost to the -- list, also taking care to swap patterns if necessary. pushKernelNesting :: Target -> LoopNesting -> KernelNest -> KernelNest @@ -234,8 +240,8 @@ -> m (Stm lore, Stms lore) constructKernel mk_lvl kernel_nest inner_body = runBinderT' $ do (ispace, inps) <- flatKernel kernel_nest - let cs = loopNestingCertificates first_nest - ispace_scope = M.fromList $ zip (map fst ispace) $ repeat $ IndexInfo Int32 + let aux = loopNestingAux first_nest + ispace_scope = M.fromList $ zip (map fst ispace) $ repeat $ IndexName Int32 pat = loopNestingPattern first_nest rts = map (stripArray (length ispace)) $ patternTypes pat @@ -248,7 +254,7 @@ addStms aux_stms - return $ Let pat (StmAux cs ()) $ Op $ segOp segop + return $ Let pat aux $ Op $ segOp segop where first_nest = fst kernel_nest inputIsUsed input = kernelInputName input `nameIn` freeIn inner_body @@ -299,7 +305,7 @@ distributionInnerPattern :: DistributionBody -> PatternT Type distributionInnerPattern = fst . innerTarget . distributionTarget -distributionBodyFromStms :: Attributes lore => +distributionBodyFromStms :: ASTLore lore => Targets -> Stms lore -> (DistributionBody, Result) distributionBodyFromStms (Targets (inner_pat, inner_res) targets) stms = let bound_by_stms = namesFromList $ M.keys $ scopeOf stms @@ -313,7 +319,7 @@ }, inner_res') -distributionBodyFromStm :: Attributes lore => +distributionBodyFromStm :: ASTLore lore => Targets -> Stm lore -> (DistributionBody, Result) distributionBodyFromStm targets bnd = distributionBodyFromStms targets $ oneStm bnd @@ -353,7 +359,7 @@ identity_map inner_returned_arrs addTarget = do - let nest'@(MapNesting _ cs w params_and_arrs) = + let nest'@(MapNesting _ aux w params_and_arrs) = removeUnusedNestingParts free_in_kernel nest (params,arrs) = unzip params_and_arrs param_names = namesFromList $ map paramName params @@ -397,7 +403,7 @@ nest'' = removeUnusedNestingParts free_in_kernel $ - MapNesting pat cs w $ zip actual_params actual_arrs + MapNesting pat aux w $ zip actual_params actual_arrs free_in_kernel'' = (freeIn nest'' <> free_in_kernel) `namesSubtract` actual_param_names @@ -441,8 +447,8 @@ ((`pushOuterTarget` kernel_targets) . expand_target) removeUnusedNestingParts :: Names -> LoopNesting -> LoopNesting -removeUnusedNestingParts used (MapNesting pat cs w params_and_arrs) = - MapNesting pat cs w $ zip used_params used_arrs +removeUnusedNestingParts used (MapNesting pat aux w params_and_arrs) = + MapNesting pat aux w $ zip used_params used_arrs where (params,arrs) = unzip params_and_arrs (used_params, used_arrs) = unzip $ @@ -508,7 +514,7 @@ return Nothing where (dist_body, inner_body_res) = distributionBodyFromStms targets stms -tryDistributeStm :: (MonadFreshNames m, HasScope t m, Attributes lore) => +tryDistributeStm :: (MonadFreshNames m, HasScope t m, ASTLore lore) => Nestings -> Targets -> Stm lore -> m (Maybe (Result, Targets, KernelNest)) tryDistributeStm nest targets bnd = diff --git a/src/Futhark/Pass/ExtractKernels/ISRWIM.hs b/src/Futhark/Pass/ExtractKernels/ISRWIM.hs --- a/src/Futhark/Pass/ExtractKernels/ISRWIM.hs +++ b/src/Futhark/Pass/ExtractKernels/ISRWIM.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} +-- | Interchanging scans with inner maps. module Futhark.Pass.ExtractKernels.ISRWIM ( iswim , irwim @@ -11,7 +12,7 @@ import Control.Monad.State import Futhark.MonadFreshNames -import Futhark.Representation.SOACS +import Futhark.IR.SOACS import Futhark.Tools -- | Interchange Scan With Inner Map. Tries to turn a @scan(map)@ into a @@ -53,7 +54,7 @@ mapM (newIdent' (<>"_transposed") . transposeIdentType) $ patternValueIdents res_pat - addStm $ Let res_pat' (StmAux map_cs ()) $ Op $ Screma map_w + addStm $ Let res_pat' (StmAux map_cs mempty ()) $ Op $ Screma map_w (mapSOAC map_fun') map_arrs' forM_ (zip (patternValueIdents res_pat) @@ -110,9 +111,12 @@ let map_fun' = Lambda map_params map_body map_rettype - addStm $ Let res_pat (StmAux map_cs ()) $ Op $ Screma map_w (mapSOAC map_fun') arrs' + addStm $ Let res_pat (StmAux map_cs mempty ()) $ + Op $ Screma map_w (mapSOAC map_fun') arrs' | otherwise = Nothing +-- | Does this reduce operator contain an inner map, and if so, what +-- does that map look like? rwimPossible :: Lambda -> Maybe (Pattern, Certificates, SubExp, Lambda) rwimPossible fun @@ -136,12 +140,12 @@ removeParamOuterDim :: LParam -> LParam removeParamOuterDim param = let t = rowType $ paramType param - in param { paramAttr = t } + in param { paramDec = t } setParamOuterDimTo :: SubExp -> LParam -> LParam setParamOuterDimTo w param = let t = setOuterDimTo w $ paramType param - in param { paramAttr = t } + in param { paramDec = t } setIdentOuterDimTo :: SubExp -> Ident -> Ident setIdentOuterDimTo w ident = diff --git a/src/Futhark/Pass/ExtractKernels/Interchange.hs b/src/Futhark/Pass/ExtractKernels/Interchange.hs --- a/src/Futhark/Pass/ExtractKernels/Interchange.hs +++ b/src/Futhark/Pass/ExtractKernels/Interchange.hs @@ -21,7 +21,7 @@ import Futhark.Pass.ExtractKernels.Distribution (LoopNesting(..), KernelNest, kernelNestLoops) -import Futhark.Representation.SOACS +import Futhark.IR.SOACS import Futhark.MonadFreshNames import Futhark.Transform.Rename import Futhark.Tools @@ -40,7 +40,7 @@ interchangeLoop isMapParameter (SeqLoop perm loop_pat merge form body) - (MapNesting pat cs w params_and_arrs) = do + (MapNesting pat aux w params_and_arrs) = do merge_expanded <- localScope (scopeOfLParams $ map fst params_and_arrs) $ mapM expand merge @@ -64,7 +64,7 @@ body' <- mkDummyStms (params'<>new_params) body let lam = Lambda (params'<>new_params) body' rettype - map_bnd = Let loop_pat_expanded (StmAux cs ()) $ + map_bnd = Let loop_pat_expanded aux $ Op $ Screma w (mapSOAC lam) $ arrs' <> new_arrs res = map Var $ patternNames loop_pat_expanded pat' = Pattern [] $ rearrangeShape perm $ patternValueElements pat @@ -118,7 +118,7 @@ -- | Given a (parallel) map nesting and an inner sequential loop, move -- the maps inside the sequential loop. The result is several -- statements - one of these will be the loop, which will then contain --- statements with 'Map' expressions. +-- statements with @map@ expressions. interchangeLoops :: (MonadFreshNames m, HasScope SOACS m) => KernelNest -> SeqLoop -> m (Stms SOACS) @@ -131,7 +131,7 @@ fmap snd $ find ((==v) . paramName . fst) $ concatMap loopNestingParamsAndArrs $ kernelNestLoops nest -data Branch = Branch [Int] Pattern SubExp Body Body (IfAttr (BranchType SOACS)) +data Branch = Branch [Int] Pattern SubExp Body Body (IfDec (BranchType SOACS)) branchStm :: Branch -> Stm branchStm (Branch _ pat cond tbranch fbranch ret) = @@ -140,8 +140,8 @@ interchangeBranch1 :: (MonadBinder m, LocalScope SOACS m) => Branch -> LoopNesting -> m Branch interchangeBranch1 - (Branch perm branch_pat cond tbranch fbranch (IfAttr ret if_sort)) - (MapNesting pat cs w params_and_arrs) = do + (Branch perm branch_pat cond tbranch fbranch (IfDec ret if_sort)) + (MapNesting pat aux w params_and_arrs) = do let ret' = map (`arrayOfRow` Free w) ret pat' = Pattern [] $ rearrangeShape perm $ patternValueElements pat @@ -161,16 +161,16 @@ resultBody <$> (mapM (dummyBindIfNotIn bound_in_branch) =<< bodyBind branch) let lam = Lambda params branch' lam_ret res = map Var $ patternNames branch_pat' - map_bnd = Let branch_pat' (StmAux cs ()) $ Op $ Screma w (mapSOAC lam) arrs + map_bnd = Let branch_pat' aux $ Op $ Screma w (mapSOAC lam) arrs return $ mkBody (oneStm map_bnd) res tbranch' <- mkBranch tbranch fbranch' <- mkBranch fbranch return $ Branch [0..patternSize pat-1] pat' cond tbranch' fbranch' $ - IfAttr ret' if_sort + IfDec ret' if_sort where dummyBind se = do dummy <- newVName "dummy" - letBindNames_ [dummy] (BasicOp $ SubExp se) + letBindNames [dummy] (BasicOp $ SubExp se) return $ Var dummy dummyBindIfNotIn bound_in_branch se diff --git a/src/Futhark/Pass/ExtractKernels/Intragroup.hs b/src/Futhark/Pass/ExtractKernels/Intragroup.hs --- a/src/Futhark/Pass/ExtractKernels/Intragroup.hs +++ b/src/Futhark/Pass/ExtractKernels/Intragroup.hs @@ -16,9 +16,9 @@ import Prelude hiding (log) import Futhark.Analysis.PrimExp.Convert -import Futhark.Representation.SOACS -import qualified Futhark.Representation.Kernels as Out -import Futhark.Representation.Kernels.Kernel hiding (HistOp) +import Futhark.IR.SOACS +import qualified Futhark.IR.Kernels as Out +import Futhark.IR.Kernels.Kernel hiding (HistOp) import Futhark.MonadFreshNames import Futhark.Tools import Futhark.Pass.ExtractKernels.DistributeNests @@ -80,7 +80,7 @@ -- The group size is either the maximum of the minimum parallelism -- exploited, or the desired parallelism (bounded by the max group -- size) in case there is no minimum. - letBindNames_ [group_size] =<< + letBindNames [group_size] =<< if null ws_min then eBinOp (SMin Int32) (eSubExp =<< letSubExp "max_group_size" (Op $ SizeOp $ Out.GetSizeMax Out.SizeGroup)) @@ -100,13 +100,14 @@ let nested_pat = loopNestingPattern first_nest rts = map (length ispace `stripArray`) $ patternTypes nested_pat lvl = SegGroup (Count num_groups) (Count $ Var group_size) SegNoVirt - kstm = Let nested_pat (StmAux cs ()) $ Op $ SegOp $ SegMap lvl kspace rts kbody' + kstm = Let nested_pat aux $ + Op $ SegOp $ SegMap lvl kspace rts kbody' let intra_min_par = intra_avail_par return ((intra_min_par, intra_avail_par), Var group_size, log, prelude_stms, oneStm kstm) where first_nest = fst knest - cs = loopNestingCertificates first_nest + aux = loopNestingAux first_nest data Acc = Acc { accMinPar :: S.Set [SubExp] , accAvailPar :: S.Set [SubExp] @@ -155,20 +156,20 @@ localScope (scopeOfFParams $ map fst $ ctx ++ val) $ do loopbody' <- intraGroupBody lvl loopbody certifying (stmAuxCerts aux) $ - letBind_ pat $ DoLoop ctx val form' loopbody' + letBind pat $ DoLoop ctx val form' loopbody' where form' = case form of ForLoop i it bound inps -> ForLoop i it bound inps WhileLoop cond -> WhileLoop cond - If cond tbody fbody ifattr -> do + If cond tbody fbody ifdec -> do tbody' <- intraGroupBody lvl tbody fbody' <- intraGroupBody lvl fbody certifying (stmAuxCerts aux) $ - letBind_ pat $ If cond tbody' fbody' ifattr + letBind pat $ If cond tbody' fbody' ifdec Op (Screma w form arrs) | Just lam <- isMapSOAC form -> do - let loopnest = MapNesting pat (stmAuxCerts aux) w $ zip (lambdaParams lam) arrs + let loopnest = MapNesting pat aux w $ zip (lambdaParams lam) arrs env = DistEnv { distNest = singleNesting $ Nesting mempty loopnest , distScope = @@ -242,7 +243,7 @@ (dests_ws, dests_ns, dests_vs) = unzip3 dests (i_res, v_res) = splitAt (sum dests_ns) $ bodyResult $ lambdaBody lam' krets = do (a_w, a, is_vs) <- zip3 dests_ws dests_vs $ chunks dests_ns $ zip i_res v_res - return $ WriteReturns [a_w] a [ ([i],v) | (i,v) <- is_vs ] + return $ WriteReturns [a_w] a [ ([DimFix i],v) | (i,v) <- is_vs ] inputs = do (p, p_a) <- zip (lambdaParams lam') ivs return $ KernelInput (paramName p) (paramType p) p_a [Var write_i] @@ -253,7 +254,7 @@ certifying (stmAuxCerts aux) $ do let ts = map rowType $ patternTypes pat body = KernelBody () kstms krets - letBind_ pat $ Op $ SegOp $ SegMap lvl' space ts body + letBind pat $ Op $ SegOp $ SegMap lvl' space ts body parallelMin [w] diff --git a/src/Futhark/Pass/ExtractKernels/StreamKernel.hs b/src/Futhark/Pass/ExtractKernels/StreamKernel.hs --- a/src/Futhark/Pass/ExtractKernels/StreamKernel.hs +++ b/src/Futhark/Pass/ExtractKernels/StreamKernel.hs @@ -15,8 +15,8 @@ import Prelude hiding (quot) import Futhark.Analysis.PrimExp -import Futhark.Representation.AST -import Futhark.Representation.Kernels +import Futhark.IR +import Futhark.IR.Kernels hiding (Prog, Body, Stm, Pattern, PatElem, BasicOp, Exp, Lambda, FunDef, FParam, LParam, RetType) import Futhark.Pass.ExtractKernels.BlockedKernel @@ -59,7 +59,7 @@ -> SplitOrdering -> SubExp -> SubExp -> SubExp -> [VName] -> m () splitArrays chunk_size split_bound ordering w i elems_per_i arrs = do - letBindNames_ [chunk_size] $ Op $ SizeOp $ SplitSpace ordering w i elems_per_i + letBindNames [chunk_size] $ Op $ SizeOp $ SplitSpace ordering w i elems_per_i case ordering of SplitContiguous -> do offset <- letSubExp "slice_offset" $ BasicOp $ BinOp (Mul Int32 OverflowUndef) i elems_per_i @@ -68,13 +68,20 @@ where contiguousSlice offset slice_name arr = do arr_t <- lookupType arr let slice = fullSlice arr_t [DimSlice offset (Var chunk_size) (constant (1::Int32))] - letBindNames_ [slice_name] $ BasicOp $ Index arr slice + letBindNames [slice_name] $ BasicOp $ Index arr slice stridedSlice stride slice_name arr = do arr_t <- lookupType arr let slice = fullSlice arr_t [DimSlice i (Var chunk_size) stride] - letBindNames_ [slice_name] $ BasicOp $ Index arr slice + letBindNames [slice_name] $ BasicOp $ Index arr slice +partitionChunkedKernelFoldParameters :: Int -> [Param dec] + -> (VName, Param dec, [Param dec], [Param dec]) +partitionChunkedKernelFoldParameters num_accs (i_param : chunk_param : params) = + let (acc_params, arr_params) = splitAt num_accs params + in (paramName i_param, chunk_param, acc_params, arr_params) +partitionChunkedKernelFoldParameters _ _ = + error "partitionChunkedKernelFoldParameters: lambda takes too few parameters" blockedPerThread :: (MonadBinder m, Lore m ~ Kernels) => VName -> SubExp -> KernelSize -> StreamOrd -> Lambda (Lore m) @@ -194,7 +201,7 @@ (_, kspace, ts, kbody) <- prepareStream size ispace w comm fold_lam nes arrs lvl <- mk_lvl [w] "stream_red" $ NoRecommendation SegNoVirt - letBind_ pat' $ Op $ SegOp $ SegRed lvl kspace + letBind pat' $ Op $ SegOp $ SegRed lvl kspace [SegBinOp comm red_lam nes mempty] ts kbody read_dummy @@ -217,7 +224,7 @@ let pat = Pattern [] $ redout_pes ++ mapout_pes lvl <- mk_lvl [w] "stream_map" $ NoRecommendation SegNoVirt - letBind_ pat $ Op $ SegOp $ SegMap lvl kspace ts kbody + letBind pat $ Op $ SegOp $ SegMap lvl kspace ts kbody return (threads, map patElemName redout_pes) diff --git a/src/Futhark/Pass/ExtractKernels/ToKernels.hs b/src/Futhark/Pass/ExtractKernels/ToKernels.hs --- a/src/Futhark/Pass/ExtractKernels/ToKernels.hs +++ b/src/Futhark/Pass/ExtractKernels/ToKernels.hs @@ -16,10 +16,10 @@ import Data.List () import Futhark.Analysis.Rephrase -import Futhark.Representation.AST -import Futhark.Representation.SOACS (SOACS) -import qualified Futhark.Representation.SOACS.SOAC as SOAC -import Futhark.Representation.Kernels +import Futhark.IR +import Futhark.IR.SOACS (SOACS) +import qualified Futhark.IR.SOACS.SOAC as SOAC +import Futhark.IR.Kernels import Futhark.Tools getSize :: (MonadBinder m, Op (Lore m) ~ HostOp (Lore m) inner) => @@ -38,8 +38,8 @@ injectSOACS :: (Monad m, SameScope from to, - ExpAttr from ~ ExpAttr to, - BodyAttr from ~ BodyAttr to, + ExpDec from ~ ExpDec to, + BodyDec from ~ BodyDec to, RetType from ~ RetType to, BranchType from ~ BranchType to, Op from ~ SOAC from) => diff --git a/src/Futhark/Pass/FirstOrderTransform.hs b/src/Futhark/Pass/FirstOrderTransform.hs --- a/src/Futhark/Pass/FirstOrderTransform.hs +++ b/src/Futhark/Pass/FirstOrderTransform.hs @@ -1,17 +1,37 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} +-- | Transform any SOACs to @for@-loops. +-- +-- Example: +-- +-- @ +-- let ys = map (\x -> x + 2) xs +-- @ +-- +-- becomes something like: +-- +-- @ +-- let out = scratch n i32 +-- let ys = +-- loop (ys' = out) for i < n do +-- let x = xs[i] +-- let y = x + 2 +-- let ys'[i] = y +-- in ys' +-- @ module Futhark.Pass.FirstOrderTransform ( firstOrderTransform ) where -import Futhark.Transform.FirstOrderTransform (FirstOrderLore, transformFunDef, transformStms) -import Futhark.Representation.SOACS (SOACS, scopeOf) +import Futhark.Transform.FirstOrderTransform (FirstOrderLore, transformFunDef, transformConsts) +import Futhark.IR.SOACS (SOACS, scopeOf) import Futhark.Pass +-- | The first-order transformation pass. firstOrderTransform :: FirstOrderLore lore => Pass SOACS lore firstOrderTransform = Pass "first order transform" "Transform all SOACs to for-loops." $ intraproceduralTransformationWithConsts - transformStms (transformFunDef . scopeOf) + transformConsts (transformFunDef . scopeOf) diff --git a/src/Futhark/Pass/KernelBabysitting.hs b/src/Futhark/Pass/KernelBabysitting.hs --- a/src/Futhark/Pass/KernelBabysitting.hs +++ b/src/Futhark/Pass/KernelBabysitting.hs @@ -1,10 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} -- | Do various kernel optimisations - mostly related to coalescing. -module Futhark.Pass.KernelBabysitting - ( babysitKernels - , nonlinearInMemory - ) +module Futhark.Pass.KernelBabysitting ( babysitKernels ) where import Control.Arrow (first) @@ -15,14 +12,15 @@ import Data.Maybe import Futhark.MonadFreshNames -import Futhark.Representation.AST -import Futhark.Representation.Kernels +import Futhark.IR +import Futhark.IR.Kernels hiding (Prog, Body, Stm, Pattern, PatElem, BasicOp, Exp, Lambda, FunDef, FParam, LParam, RetType) import Futhark.Tools import Futhark.Pass import Futhark.Util +-- | The pass definition. babysitKernels :: Pass Kernels Kernels babysitKernels = Pass "babysit kernels" "Transpose kernel input arrays for better performance." $ @@ -131,15 +129,15 @@ onBody (variance, szsubst, scope') (lambdaBody lam) where scope' = scope <> scopeOfLParams (lambdaParams lam) - onBody (variance, szsubst, scope) (Body battr stms bres) = do + onBody (variance, szsubst, scope) (Body bdec stms bres) = do stms' <- stmsFromList <$> mapM (onStm (variance', szsubst', scope')) (stmsToList stms) - Body battr stms' <$> pure bres + pure $ Body bdec stms' bres where variance' = varianceInStms variance stms szsubst' = mkSizeSubsts stms <> szsubst scope' = scope <> scopeOf stms - onStm (variance, szsubst, _) (Let pat attr (BasicOp (Index arr is))) = - Let pat attr . oldOrNew <$> f free_ker_vars isThreadLocal isGidVariant sizeSubst outer_scope arr is + onStm (variance, szsubst, _) (Let pat dec (BasicOp (Index arr is))) = + Let pat dec . oldOrNew <$> f free_ker_vars isThreadLocal isGidVariant sizeSubst outer_scope arr is where oldOrNew Nothing = BasicOp $ Index arr is oldOrNew (Just (arr', is')) = @@ -159,8 +157,8 @@ | Just v' <- M.lookup v szsubst = sizeSubst v' | otherwise = Nothing - onStm (variance, szsubst, scope) (Let pat attr e) = - Let pat attr <$> mapExpM (mapper (variance, szsubst, scope)) e + onStm (variance, szsubst, scope) (Let pat dec e) = + Let pat dec <$> mapExpM (mapper (variance, szsubst, scope)) e onOp ctx (OtherOp soac) = OtherOp <$> mapSOACM identitySOACMapper{ mapOnSOACLambda = onLambda ctx } soac @@ -384,7 +382,7 @@ Int -> SubExp -> PrimExp VName -> VName -> m VName rearrangeSlice d w num_chunks arr = do - num_chunks' <- letSubExp "num_chunks" =<< toExp num_chunks + num_chunks' <- toSubExp "num_chunks" num_chunks (w_padded, padding) <- paddedScanReduceInput w num_chunks' diff --git a/src/Futhark/Pass/ResolveAssertions.hs b/src/Futhark/Pass/ResolveAssertions.hs --- a/src/Futhark/Pass/ResolveAssertions.hs +++ b/src/Futhark/Pass/ResolveAssertions.hs @@ -17,11 +17,11 @@ import qualified Futhark.Analysis.AlgSimplify as AS import qualified Futhark.Analysis.ScalExp as SE import Futhark.Analysis.PrimExp.Convert -import Futhark.Representation.AST.Syntax +import Futhark.IR.Syntax import Futhark.Construct import Futhark.Pass -import Futhark.Representation.SOACS (SOACS) -import qualified Futhark.Representation.SOACS.Simplify as Simplify +import Futhark.IR.SOACS (SOACS) +import qualified Futhark.IR.SOACS.Simplify as Simplify import qualified Futhark.Optimise.Simplify as Simplify import Prelude @@ -44,7 +44,7 @@ isNothing $ valOrVar se, SE.scalExpSize se < size_bound, Just se' <- valOrVar $ AS.simplify se ranges -> - letBind_ pat $ BasicOp $ SubExp se' + letBind pat $ BasicOp $ SubExp se' _ -> cannotSimplify where ranges = ST.rangesRep vtable size_bound = 10 -- don't touch scalexps bigger than this. diff --git a/src/Futhark/Pass/Simplify.hs b/src/Futhark/Pass/Simplify.hs --- a/src/Futhark/Pass/Simplify.hs +++ b/src/Futhark/Pass/Simplify.hs @@ -9,14 +9,14 @@ ) where -import qualified Futhark.Representation.SOACS.Simplify as SOACS -import qualified Futhark.Representation.Kernels.Simplify as Kernels -import qualified Futhark.Representation.Seq as Seq -import qualified Futhark.Representation.KernelsMem as KernelsMem -import qualified Futhark.Representation.SeqMem as SeqMem +import qualified Futhark.IR.SOACS.Simplify as SOACS +import qualified Futhark.IR.Kernels.Simplify as Kernels +import qualified Futhark.IR.Seq as Seq +import qualified Futhark.IR.KernelsMem as KernelsMem +import qualified Futhark.IR.SeqMem as SeqMem import Futhark.Pass -import Futhark.Representation.AST.Syntax +import Futhark.IR.Syntax simplify :: (Prog lore -> PassM (Prog lore)) -> Pass lore lore diff --git a/src/Futhark/Passes.hs b/src/Futhark/Passes.hs --- a/src/Futhark/Passes.hs +++ b/src/Futhark/Passes.hs @@ -28,11 +28,11 @@ import Futhark.Pass.ResolveAssertions import Futhark.Pass.Simplify import Futhark.Pipeline -import Futhark.Representation.KernelsMem (KernelsMem) -import Futhark.Representation.SeqMem (SeqMem) -import Futhark.Representation.Kernels (Kernels) -import Futhark.Representation.Seq (Seq) -import Futhark.Representation.SOACS (SOACS) +import Futhark.IR.KernelsMem (KernelsMem) +import Futhark.IR.SeqMem (SeqMem) +import Futhark.IR.Kernels (Kernels) +import Futhark.IR.Seq (Seq) +import Futhark.IR.SOACS (SOACS) standardPipeline :: Pipeline SOACS SOACS standardPipeline = diff --git a/src/Futhark/Pipeline.hs b/src/Futhark/Pipeline.hs --- a/src/Futhark/Pipeline.hs +++ b/src/Futhark/Pipeline.hs @@ -1,4 +1,14 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleContexts, OverloadedStrings #-} +{-# LANGUAGE Trustworthy #-} +-- | Definition of the core compiler driver building blocks. The +-- spine of the compiler is the 'FutharkM' monad, although note that +-- individual passes are pure functions, and do not use the 'FutharkM' +-- monad (see "Futhark.Pass"). +-- +-- Running the compiler involves producing an initial IR program (see +-- "Futhark.Compiler.Program"), running a 'Pipeline' to produce a +-- final program (still in IR), then running an 'Action', which is +-- usually a code generator. module Futhark.Pipeline ( Pipeline , PipelineConfig (..) @@ -8,13 +18,11 @@ , runFutharkM , Verbosity(..) - , internalErrorS - , module Futhark.Error , onePass , passes - , runPasses + , runPipeline ) where @@ -34,22 +42,27 @@ import qualified Futhark.Analysis.Alias as Alias import Futhark.Error -import Futhark.Representation.AST (Prog, PrettyLore) +import Futhark.IR (Prog, PrettyLore) import Futhark.TypeCheck import Futhark.Pass import Futhark.Util.Log -import Futhark.Util.Pretty (Pretty, prettyText) +import Futhark.Util.Pretty (prettyText) import Futhark.MonadFreshNames --- | If Verbose, print log messages to standard error. If --- VeryVerbose, also print logs from individual passes. -data Verbosity = NotVerbose | Verbose | VeryVerbose deriving (Eq, Ord) +-- | How much information to print to stderr while the compiler is running. +data Verbosity + = NotVerbose -- ^ Silence is golden. + | Verbose -- ^ Print messages about which pass is running. + | VeryVerbose -- ^ Also print logs from individual passes. + deriving (Eq, Ord) newtype FutharkEnv = FutharkEnv { futharkVerbose :: Verbosity } data FutharkState = FutharkState { futharkPrevLog :: UTCTime , futharkNameSource :: VNameSource } +-- | The main Futhark compiler driver monad - basically some state +-- tracking on top if 'IO'. newtype FutharkM a = FutharkM (ExceptT CompilerError (StateT FutharkState (ReaderT FutharkEnv IO)) a) deriving (Applicative, Functor, Monad, MonadError CompilerError, @@ -73,26 +86,29 @@ modify $ \s -> s { futharkPrevLog = now } when verb $ liftIO $ T.hPutStrLn stderr $ T.pack prefix <> msg +-- | Run a 'FutharkM' action. runFutharkM :: FutharkM a -> Verbosity -> IO (Either CompilerError a) runFutharkM (FutharkM m) verbose = do s <- FutharkState <$> getCurrentTime <*> pure blankNameSource runReaderT (evalStateT (runExceptT m) s) newEnv where newEnv = FutharkEnv verbose -internalErrorS :: Pretty t => String -> t -> FutharkM a -internalErrorS s p = throwError $ InternalError (T.pack s) (prettyText p) CompilerBug - +-- | A compilation always ends with some kind of action. data Action lore = Action { actionName :: String , actionDescription :: String , actionProcedure :: Prog lore -> FutharkM () } +-- | Configuration object for running a compiler pipeline. data PipelineConfig = PipelineConfig { pipelineVerbose :: Bool , pipelineValidate :: Bool } +-- | A compiler pipeline is conceptually a function from programs to +-- programs, where the actual representation may change. Pipelines +-- can be composed using their 'Category' instance. newtype Pipeline fromlore tolore = Pipeline { unPipeline :: PipelineConfig -> Prog fromlore -> FutharkM (Prog tolore) } @@ -100,14 +116,16 @@ id = Pipeline $ const return p2 . p1 = Pipeline perform where perform cfg prog = - runPasses p2 cfg =<< runPasses p1 cfg prog + runPipeline p2 cfg =<< runPipeline p1 cfg prog -runPasses :: Pipeline fromlore tolore - -> PipelineConfig - -> Prog fromlore - -> FutharkM (Prog tolore) -runPasses = unPipeline +-- | Run the pipeline on the given program. +runPipeline :: Pipeline fromlore tolore + -> PipelineConfig + -> Prog fromlore + -> FutharkM (Prog tolore) +runPipeline = unPipeline +-- | Construct a pipeline from a single compiler pass. onePass :: Checkable tolore => Pass fromlore tolore -> Pipeline fromlore tolore onePass pass = Pipeline perform @@ -122,6 +140,7 @@ Right () -> return () return prog' +-- | Create a pipeline from a list of passes. passes :: Checkable lore => [Pass lore lore] -> Pipeline lore lore passes = foldl (>>>) id . map onePass diff --git a/src/Futhark/Pkg/Info.hs b/src/Futhark/Pkg/Info.hs --- a/src/Futhark/Pkg/Info.hs +++ b/src/Futhark/Pkg/Info.hs @@ -296,6 +296,7 @@ modifyPkgRegistry :: (PkgRegistry m -> PkgRegistry m) -> m () modifyPkgRegistry f = putPkgRegistry . f =<< getPkgRegistry +-- | Given a package path, look up information about that package. lookupPackage :: MonadPkgRegistry m => PkgPath -> m (PkgInfo m) lookupPackage p = do diff --git a/src/Futhark/Representation/AST.hs b/src/Futhark/Representation/AST.hs deleted file mode 100644 --- a/src/Futhark/Representation/AST.hs +++ /dev/null @@ -1,16 +0,0 @@ --- | A convenient re-export of basic AST modules. Note that --- "Futhark.Representation.AST.Lore" is not exported, as this would --- cause name clashes. You are advised to use a qualified import of --- the lore module, if you need it. -module Futhark.Representation.AST - ( module Futhark.Representation.AST.Attributes - , module Futhark.Representation.AST.Traversals - , module Futhark.Representation.AST.Pretty - , module Futhark.Representation.AST.Syntax - ) -where - -import Futhark.Representation.AST.Syntax -import Futhark.Representation.AST.Attributes -import Futhark.Representation.AST.Traversals -import Futhark.Representation.AST.Pretty diff --git a/src/Futhark/Representation/AST/Annotations.hs b/src/Futhark/Representation/AST/Annotations.hs deleted file mode 100644 --- a/src/Futhark/Representation/AST/Annotations.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE TypeFamilies, FlexibleContexts #-} -module Futhark.Representation.AST.Annotations - ( Annotations (..) - , module Futhark.Representation.AST.RetType - ) - where - -import qualified Data.Kind - -import Futhark.Representation.AST.Syntax.Core -import Futhark.Representation.AST.RetType -import Futhark.Representation.AST.Attributes.Types - -class (Show (LetAttr l), Show (ExpAttr l), Show (BodyAttr l), Show (FParamAttr l), Show (LParamAttr l), Show (RetType l), Show (BranchType l), Show (Op l), - Eq (LetAttr l), Eq (ExpAttr l), Eq (BodyAttr l), Eq (FParamAttr l), Eq (LParamAttr l), Eq (RetType l), Eq (BranchType l), Eq (Op l), - Ord (LetAttr l), Ord (ExpAttr l), Ord (BodyAttr l), Ord (FParamAttr l), Ord (LParamAttr l), Ord (RetType l), Ord (BranchType l), Ord (Op l), - IsRetType (RetType l), IsBodyType (BranchType l), - Typed (FParamAttr l), Typed (LParamAttr l), Typed (LetAttr l), - DeclTyped (FParamAttr l)) - => Annotations l where - -- | Annotation for every let-pattern element. - type LetAttr l :: Data.Kind.Type - type LetAttr l = Type - -- | Annotation for every expression. - type ExpAttr l :: Data.Kind.Type - type ExpAttr l = () - -- | Annotation for every body. - type BodyAttr l :: Data.Kind.Type - type BodyAttr l = () - -- | Annotation for every (non-lambda) function parameter. - type FParamAttr l :: Data.Kind.Type - type FParamAttr l = DeclType - -- | Annotation for every lambda function parameter. - type LParamAttr l :: Data.Kind.Type - type LParamAttr l = Type - - -- | The return type annotation of function calls. - type RetType l :: Data.Kind.Type - type RetType l = DeclExtType - - -- | The return type annotation of branches. - type BranchType l :: Data.Kind.Type - type BranchType l = ExtType - - -- | Extensible operation. - type Op l :: Data.Kind.Type - type Op l = () diff --git a/src/Futhark/Representation/AST/Attributes.hs b/src/Futhark/Representation/AST/Attributes.hs deleted file mode 100644 --- a/src/Futhark/Representation/AST/Attributes.hs +++ /dev/null @@ -1,221 +0,0 @@ -{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances, ConstraintKinds #-} --- | This module provides various simple ways to query and manipulate --- fundamental Futhark terms, such as types and values. The intent is to --- keep "Futhark.Reprsentation.AST.Syntax" simple, and put whatever --- embellishments we need here. This is an internal, desugared --- representation. -module Futhark.Representation.AST.Attributes - ( module Futhark.Representation.AST.Attributes.Reshape - , module Futhark.Representation.AST.Attributes.Rearrange - , module Futhark.Representation.AST.Attributes.Types - , module Futhark.Representation.AST.Attributes.Constants - , module Futhark.Representation.AST.Attributes.TypeOf - , module Futhark.Representation.AST.Attributes.Patterns - , module Futhark.Representation.AST.Attributes.Names - , module Futhark.Representation.AST.RetType - - -- * Built-in functions - , isBuiltInFunction - , builtInFunctions - - -- * Extra tools - , asBasicOp - , safeExp - , subExpVars - , subExpVar - , shapeVars - , commutativeLambda - , entryPointSize - , defAux - , stmCerts - , certify - , expExtTypesFromPattern - - , ASTConstraints - , IsOp (..) - , Attributes (..) - ) - where - -import Data.List (find) -import Data.Maybe (mapMaybe, isJust) -import qualified Data.Map.Strict as M - -import Futhark.Representation.AST.Attributes.Reshape -import Futhark.Representation.AST.Attributes.Rearrange -import Futhark.Representation.AST.Attributes.Types -import Futhark.Representation.AST.Attributes.Constants -import Futhark.Representation.AST.Attributes.Patterns -import Futhark.Representation.AST.Attributes.Names -import Futhark.Representation.AST.Attributes.TypeOf -import Futhark.Representation.AST.RetType -import Futhark.Representation.AST.Syntax -import Futhark.Representation.AST.Pretty -import Futhark.Transform.Rename (Rename, Renameable) -import Futhark.Transform.Substitute (Substitute, Substitutable) -import Futhark.Util.Pretty - --- | @isBuiltInFunction k@ is 'True' if @k@ is an element of 'builtInFunctions'. -isBuiltInFunction :: Name -> Bool -isBuiltInFunction fnm = fnm `M.member` builtInFunctions - --- | A map of all built-in functions and their types. -builtInFunctions :: M.Map Name (PrimType,[PrimType]) -builtInFunctions = M.fromList $ map namify $ M.toList primFuns - where namify (k,(paramts,ret,_)) = (nameFromString k, (ret, paramts)) - --- | If the expression is a 'BasicOp', return that 'BasicOp', otherwise 'Nothing'. -asBasicOp :: Exp lore -> Maybe BasicOp -asBasicOp (BasicOp op) = Just op -asBasicOp _ = Nothing - --- | An expression is safe if it is always well-defined (assuming that --- any required certificates have been checked) in any context. For --- example, array indexing is not safe, as the index may be out of --- bounds. On the other hand, adding two numbers cannot fail. -safeExp :: IsOp (Op lore) => Exp lore -> Bool -safeExp (BasicOp op) = safeBasicOp op - where safeBasicOp (BinOp SDiv{} _ (Constant y)) = not $ zeroIsh y - safeBasicOp (BinOp SDiv{} _ _) = False - safeBasicOp (BinOp UDiv{} _ (Constant y)) = not $ zeroIsh y - safeBasicOp (BinOp UDiv{} _ _) = False - safeBasicOp (BinOp SMod{} _ (Constant y)) = not $ zeroIsh y - safeBasicOp (BinOp SMod{} _ _) = False - safeBasicOp (BinOp UMod{} _ (Constant y)) = not $ zeroIsh y - safeBasicOp (BinOp UMod{} _ _) = False - - safeBasicOp (BinOp SQuot{} _ (Constant y)) = not $ zeroIsh y - safeBasicOp (BinOp SQuot{} _ _) = False - safeBasicOp (BinOp SRem{} _ (Constant y)) = not $ zeroIsh y - safeBasicOp (BinOp SRem{} _ _) = False - - safeBasicOp (BinOp Pow{} _ (Constant y)) = not $ negativeIsh y - safeBasicOp (BinOp Pow{} _ _) = False - safeBasicOp ArrayLit{} = True - safeBasicOp BinOp{} = True - safeBasicOp SubExp{} = True - safeBasicOp UnOp{} = True - safeBasicOp CmpOp{} = True - safeBasicOp ConvOp{} = True - safeBasicOp Scratch{} = True - safeBasicOp Concat{} = True - safeBasicOp Reshape{} = True - safeBasicOp Rearrange{} = True - safeBasicOp Manifest{} = True - safeBasicOp Iota{} = True - safeBasicOp Replicate{} = True - safeBasicOp Copy{} = True - safeBasicOp _ = False - -safeExp (DoLoop _ _ _ body) = safeBody body -safeExp (Apply fname _ _ _) = - isBuiltInFunction fname -safeExp (If _ tbranch fbranch _) = - all (safeExp . stmExp) (bodyStms tbranch) && - all (safeExp . stmExp) (bodyStms fbranch) -safeExp (Op op) = safeOp op - -safeBody :: IsOp (Op lore) => Body lore -> Bool -safeBody = all (safeExp . stmExp) . bodyStms - --- | Return the variable names used in 'Var' subexpressions. May contain --- duplicates. -subExpVars :: [SubExp] -> [VName] -subExpVars = mapMaybe subExpVar - --- | If the 'SubExp' is a 'Var' return the variable name. -subExpVar :: SubExp -> Maybe VName -subExpVar (Var v) = Just v -subExpVar Constant{} = Nothing - --- | Return the variable dimension sizes. May contain --- duplicates. -shapeVars :: Shape -> [VName] -shapeVars = subExpVars . shapeDims - --- | Does the given lambda represent a known commutative function? --- Based on pattern matching and checking whether the lambda --- represents a known arithmetic operator; don't expect anything --- clever here. -commutativeLambda :: Lambda lore -> Bool -commutativeLambda lam = - let body = lambdaBody lam - n2 = length (lambdaParams lam) `div` 2 - (xps,yps) = splitAt n2 (lambdaParams lam) - - okComponent c = isJust $ find (okBinOp c) $ bodyStms body - okBinOp (xp,yp,Var r) (Let (Pattern [] [pe]) _ (BasicOp (BinOp op (Var x) (Var y)))) = - patElemName pe == r && - commutativeBinOp op && - ((x == paramName xp && y == paramName yp) || - (y == paramName xp && x == paramName yp)) - okBinOp _ _ = False - - in n2 * 2 == length (lambdaParams lam) && - n2 == length (bodyResult body) && - all okComponent (zip3 xps yps $ bodyResult body) - --- | How many value parameters are accepted by this entry point? This --- is used to determine which of the function parameters correspond to --- the parameters of the original function (they must all come at the --- end). -entryPointSize :: EntryPointType -> Int -entryPointSize (TypeOpaque _ x) = x -entryPointSize TypeUnsigned = 1 -entryPointSize TypeDirect = 1 - --- | A 'StmAux' with empty 'Certificates'. -defAux :: attr -> StmAux attr -defAux = StmAux mempty - --- | The certificates associated with a statement. -stmCerts :: Stm lore -> Certificates -stmCerts = stmAuxCerts . stmAux - --- | Add certificates to a statement. -certify :: Certificates -> Stm lore -> Stm lore -certify cs1 (Let pat (StmAux cs2 attr) e) = Let pat (StmAux (cs2<>cs1) attr) e - --- | A handy shorthand for properties that we usually want to things --- we stuff into ASTs. -type ASTConstraints a = - (Eq a, Ord a, Show a, Rename a, Substitute a, FreeIn a, Pretty a) - --- | A type class for operations. -class (ASTConstraints op, TypedOp op) => IsOp op where - -- | Like 'safeExp', but for arbitrary ops. - safeOp :: op -> Bool - -- | Should we try to hoist this out of branches? - cheapOp :: op -> Bool - -instance IsOp () where - safeOp () = True - cheapOp () = True - --- | Lore-specific attributes; also means the lore supports some basic --- facilities. -class (Annotations lore, - - PrettyLore lore, - - Renameable lore, Substitutable lore, - FreeAttr (ExpAttr lore), - FreeIn (LetAttr lore), - FreeAttr (BodyAttr lore), - FreeIn (FParamAttr lore), - FreeIn (LParamAttr lore), - FreeIn (RetType lore), - FreeIn (BranchType lore), - - IsOp (Op lore)) => Attributes lore where - -- | Given a pattern, construct the type of a body that would match - -- it. An implementation for many lores would be - -- 'expExtTypesFromPattern'. - expTypesFromPattern :: (HasScope lore m, Monad m) => - Pattern lore -> m [BranchType lore] - --- | Construct the type of an expression that would match the pattern. -expExtTypesFromPattern :: Typed attr => PatternT attr -> [ExtType] -expExtTypesFromPattern pat = - existentialiseExtTypes (patternContextNames pat) $ - staticShapes $ map patElemType $ patternValueElements pat diff --git a/src/Futhark/Representation/AST/Attributes/Aliases.hs b/src/Futhark/Representation/AST/Attributes/Aliases.hs deleted file mode 100644 --- a/src/Futhark/Representation/AST/Attributes/Aliases.hs +++ /dev/null @@ -1,170 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# Language FlexibleInstances, FlexibleContexts #-} -module Futhark.Representation.AST.Attributes.Aliases - ( vnameAliases - , subExpAliases - , primOpAliases - , expAliases - , patternAliases - , Aliased (..) - , AliasesOf (..) - -- * Consumption - , consumedInStm - , consumedInExp - , consumedByLambda - -- * Extensibility - , AliasedOp (..) - , CanBeAliased (..) - ) - where - -import Control.Arrow (first) -import qualified Data.Kind - -import Futhark.Representation.AST.Attributes (IsOp) -import Futhark.Representation.AST.Syntax -import Futhark.Representation.AST.Attributes.Patterns -import Futhark.Representation.AST.Attributes.Types -import Futhark.Representation.AST.Attributes.Names - -class (Annotations lore, AliasedOp (Op lore), - AliasesOf (LetAttr lore)) => Aliased lore where - bodyAliases :: Body lore -> [Names] - consumedInBody :: Body lore -> Names - -vnameAliases :: VName -> Names -vnameAliases = oneName - -subExpAliases :: SubExp -> Names -subExpAliases Constant{} = mempty -subExpAliases (Var v) = vnameAliases v - -primOpAliases :: BasicOp -> [Names] -primOpAliases (SubExp se) = [subExpAliases se] -primOpAliases (Opaque se) = [subExpAliases se] -primOpAliases (ArrayLit _ _) = [mempty] -primOpAliases BinOp{} = [mempty] -primOpAliases ConvOp{} = [mempty] -primOpAliases CmpOp{} = [mempty] -primOpAliases UnOp{} = [mempty] - -primOpAliases (Index ident _) = - [vnameAliases ident] -primOpAliases Update{} = - [mempty] -primOpAliases Iota{} = - [mempty] -primOpAliases Replicate{} = - [mempty] -primOpAliases (Repeat _ _ v) = - [vnameAliases v] -primOpAliases Scratch{} = - [mempty] -primOpAliases (Reshape _ e) = - [vnameAliases e] -primOpAliases (Rearrange _ e) = - [vnameAliases e] -primOpAliases (Rotate _ e) = - [vnameAliases e] -primOpAliases Concat{} = - [mempty] -primOpAliases Copy{} = - [mempty] -primOpAliases Manifest{} = - [mempty] -primOpAliases Assert{} = - [mempty] - -ifAliases :: ([Names], Names) -> ([Names], Names) -> [Names] -ifAliases (als1,cons1) (als2,cons2) = - map (`namesSubtract` cons) $ zipWith mappend als1 als2 - where cons = cons1 <> cons2 - -funcallAliases :: [(SubExp, Diet)] -> [TypeBase shape Uniqueness] -> [Names] -funcallAliases args t = - returnAliases t [(subExpAliases se, d) | (se,d) <- args ] - -expAliases :: (Aliased lore) => Exp lore -> [Names] -expAliases (If _ tb fb attr) = - drop (length all_aliases - length ts) all_aliases - where ts = ifReturns attr - all_aliases = ifAliases - (bodyAliases tb, consumedInBody tb) - (bodyAliases fb, consumedInBody fb) -expAliases (BasicOp op) = primOpAliases op -expAliases (DoLoop ctxmerge valmerge _ loopbody) = - map (`namesSubtract` merge_names) val_aliases - where (_ctx_aliases, val_aliases) = - splitAt (length ctxmerge) $ bodyAliases loopbody - merge_names = namesFromList $ map (paramName . fst) $ ctxmerge ++ valmerge -expAliases (Apply _ args t _) = - funcallAliases args $ retTypeValues t -expAliases (Op op) = opAliases op - -returnAliases :: [TypeBase shape Uniqueness] -> [(Names, Diet)] -> [Names] -returnAliases rts args = map returnType' rts - where returnType' (Array _ _ Nonunique) = - mconcat $ map (uncurry maskAliases) args - returnType' (Array _ _ Unique) = - mempty - returnType' (Prim _) = - mempty - returnType' Mem{} = - error "returnAliases Mem" - -maskAliases :: Names -> Diet -> Names -maskAliases _ Consume = mempty -maskAliases _ ObservePrim = mempty -maskAliases als Observe = als - -consumedInStm :: Aliased lore => Stm lore -> Names -consumedInStm = consumedInExp . stmExp - -consumedInExp :: (Aliased lore) => Exp lore -> Names -consumedInExp (Apply _ args _ _) = - mconcat (map (consumeArg . first subExpAliases) args) - where consumeArg (als, Consume) = als - consumeArg _ = mempty -consumedInExp (If _ tb fb _) = - consumedInBody tb <> consumedInBody fb -consumedInExp (DoLoop _ merge _ _) = - mconcat (map (subExpAliases . snd) $ - filter (unique . paramDeclType . fst) merge) -consumedInExp (BasicOp (Update src _ _)) = oneName src -consumedInExp (Op op) = consumedInOp op -consumedInExp _ = mempty - -consumedByLambda :: Aliased lore => Lambda lore -> Names -consumedByLambda = consumedInBody . lambdaBody - -patternAliases :: AliasesOf attr => PatternT attr -> [Names] -patternAliases = map (aliasesOf . patElemAttr) . patternElements - --- | Something that contains alias information. -class AliasesOf a where - -- | The alias of the argument element. - aliasesOf :: a -> Names - -instance AliasesOf Names where - aliasesOf = id - -instance AliasesOf attr => AliasesOf (PatElemT attr) where - aliasesOf = aliasesOf . patElemAttr - -class IsOp op => AliasedOp op where - opAliases :: op -> [Names] - consumedInOp :: op -> Names - -instance AliasedOp () where - opAliases () = [] - consumedInOp () = mempty - -class AliasedOp (OpWithAliases op) => CanBeAliased op where - type OpWithAliases op :: Data.Kind.Type - removeOpAliases :: OpWithAliases op -> op - addOpAliases :: op -> OpWithAliases op - -instance CanBeAliased () where - type OpWithAliases () = () - removeOpAliases = id - addOpAliases = id diff --git a/src/Futhark/Representation/AST/Attributes/Constants.hs b/src/Futhark/Representation/AST/Attributes/Constants.hs deleted file mode 100644 --- a/src/Futhark/Representation/AST/Attributes/Constants.hs +++ /dev/null @@ -1,76 +0,0 @@ --- | Possibly convenient facilities for constructing constants. -module Futhark.Representation.AST.Attributes.Constants - ( - IsValue (..) - , constant - , intConst - , floatConst - ) - where - -import Futhark.Representation.AST.Syntax.Core - --- | If a Haskell type is an instance of 'IsValue', it means that a --- value of that type can be converted to a Futhark 'PrimValue'. --- This is intended to cut down on boilerplate when writing compiler --- code - for example, you'll quickly grow tired of writing @Constant --- (LogVal True) loc@. -class IsValue a where - value :: a -> PrimValue - -instance IsValue Int where - value = IntValue . Int32Value . fromIntegral - -instance IsValue Int8 where - value = IntValue . Int8Value - -instance IsValue Int16 where - value = IntValue . Int16Value - -instance IsValue Int32 where - value = IntValue . Int32Value - -instance IsValue Int64 where - value = IntValue . Int64Value - -instance IsValue Word8 where - value = IntValue . Int8Value . fromIntegral - -instance IsValue Word16 where - value = IntValue . Int16Value . fromIntegral - -instance IsValue Word32 where - value = IntValue . Int32Value . fromIntegral - -instance IsValue Word64 where - value = IntValue . Int64Value . fromIntegral - -instance IsValue Double where - value = FloatValue . Float64Value - -instance IsValue Float where - value = FloatValue . Float32Value - -instance IsValue Bool where - value = BoolValue - -instance IsValue PrimValue where - value = id - -instance IsValue IntValue where - value = IntValue - -instance IsValue FloatValue where - value = FloatValue - --- | Create a 'Constant' 'SubExp' containing the given value. -constant :: IsValue v => v -> SubExp -constant = Constant . value - --- | Utility definition for reasons of type ambiguity. -intConst :: IntType -> Integer -> SubExp -intConst t v = constant $ intValue t v - --- | Utility definition for reasons of type ambiguity. -floatConst :: FloatType -> Double -> SubExp -floatConst t v = constant $ floatValue t v diff --git a/src/Futhark/Representation/AST/Attributes/Names.hs b/src/Futhark/Representation/AST/Attributes/Names.hs deleted file mode 100644 --- a/src/Futhark/Representation/AST/Attributes/Names.hs +++ /dev/null @@ -1,330 +0,0 @@ -{-# LANGUAGE FlexibleInstances, FlexibleContexts, UndecidableInstances #-} --- | Facilities for determining which names are used in some syntactic --- construct. The most important interface is the 'FreeIn' class and --- its instances, but for reasons related to the Haskell type system, --- some constructs have specialised functions. -module Futhark.Representation.AST.Attributes.Names - ( -- * Free names - Names - , nameIn - , oneName - , namesFromList - , namesToList - , namesIntersection - , namesIntersect - , namesSubtract - , mapNames - -- * Class - , FreeIn (..) - , freeIn - -- * Specialised Functions - , freeInStmsAndRes - -- * Bound Names - , boundInBody - , boundByStm - , boundByStms - , boundByLambda - -- * Efficient computation - , FreeAttr(..) - , FV - , fvBind - , fvName - , fvNames - ) - where - -import Control.Monad.State.Strict -import qualified Data.IntMap.Strict as IM -import qualified Data.Map.Strict as M -import Data.Foldable - -import Futhark.Representation.AST.Syntax -import Futhark.Representation.AST.Traversals -import Futhark.Representation.AST.Attributes.Patterns -import Futhark.Representation.AST.Attributes.Scope -import Futhark.Util.Pretty - --- | A set of names. -newtype Names = Names { unNames :: IM.IntMap VName } - deriving (Eq, Show) - -instance Semigroup Names where - vs1 <> vs2 = Names $ unNames vs1 <> unNames vs2 - -instance Monoid Names where - mempty = Names mempty - -instance Pretty Names where - ppr = ppr . namesToList - --- | Does the set of names contain this name? -nameIn :: VName -> Names -> Bool -nameIn v (Names vs) = baseTag v `IM.member` vs - --- | Construct a name set from a list. Slow. -namesFromList :: [VName] -> Names -namesFromList vs = Names $ IM.fromList $ zip (map baseTag vs) vs - --- | Turn a name set into a list of names. Slow. -namesToList :: Names -> [VName] -namesToList = IM.elems . unNames - --- | Construct a name set from a single name. -oneName :: VName -> Names -oneName v = Names $ IM.singleton (baseTag v) v - --- | The intersection of two name sets. -namesIntersection :: Names -> Names -> Names -namesIntersection (Names vs1) (Names vs2) = Names $ IM.intersection vs1 vs2 - --- | Do the two name sets intersect? -namesIntersect :: Names -> Names -> Bool -namesIntersect vs1 vs2 = not $ IM.disjoint (unNames vs1) (unNames vs2) - --- | Subtract the latter name set from the former. -namesSubtract :: Names -> Names -> Names -namesSubtract (Names vs1) (Names vs2) = Names $ IM.difference vs1 vs2 - --- | Map over the names in a set. -mapNames :: (VName -> VName) -> Names -> Names -mapNames f vs = namesFromList $ map f $ namesToList vs - --- | A computation to build a free variable set. -newtype FV = FV { unFV :: Names } --- Right now the variable set is just stored explicitly, without the --- fancy functional representation that GHC uses. Turns out it's --- faster this way. - -instance Monoid FV where - mempty = FV mempty - -instance Semigroup FV where - FV fv1 <> FV fv2 = FV $ fv1 <> fv2 - --- | Consider a variable to be bound in the given 'FV' computation. -fvBind :: Names -> FV -> FV -fvBind vs (FV fv) = FV $ fv `namesSubtract` vs - --- | Take note of a variable reference. -fvName :: VName -> FV -fvName v = FV $ oneName v - --- | Take note of a set of variable references. -fvNames :: Names -> FV -fvNames = FV - -freeWalker :: (FreeAttr (ExpAttr lore), - FreeAttr (BodyAttr lore), - FreeIn (FParamAttr lore), - FreeIn (LParamAttr lore), - FreeIn (LetAttr lore), - FreeIn (Op lore)) => - Walker lore (State FV) -freeWalker = identityWalker { - walkOnSubExp = modify . (<>) . freeIn' - , walkOnBody = modify . (<>) . freeIn' - , walkOnVName = modify . (<>) . fvName - , walkOnOp = modify . (<>) . freeIn' - } - --- | Return the set of variable names that are free in the given --- statements and result. Filters away the names that are bound by --- the statements. -freeInStmsAndRes :: (FreeIn (Op lore), - FreeIn (LetAttr lore), - FreeIn (LParamAttr lore), - FreeIn (FParamAttr lore), - FreeAttr (BodyAttr lore), - FreeAttr (ExpAttr lore)) => - Stms lore -> Result -> FV -freeInStmsAndRes stms res = - fvBind (boundByStms stms) $ foldMap freeIn' stms <> freeIn' res - --- | A class indicating that we can obtain free variable information --- from values of this type. -class FreeIn a where - freeIn' :: a -> FV - freeIn' = fvNames . freeIn - --- | The free variables of some syntactic construct. -freeIn :: FreeIn a => a -> Names -freeIn = unFV . freeIn' - -instance FreeIn FV where - freeIn' = id - -instance FreeIn () where - freeIn' () = mempty - -instance FreeIn Int where - freeIn' = const mempty - -instance (FreeIn a, FreeIn b) => FreeIn (a,b) where - freeIn' (a,b) = freeIn' a <> freeIn' b - -instance (FreeIn a, FreeIn b, FreeIn c) => FreeIn (a,b,c) where - freeIn' (a,b,c) = freeIn' a <> freeIn' b <> freeIn' c - -instance FreeIn a => FreeIn [a] where - freeIn' = foldMap freeIn' - -instance (FreeAttr (ExpAttr lore), - FreeAttr (BodyAttr lore), - FreeIn (FParamAttr lore), - FreeIn (LParamAttr lore), - FreeIn (LetAttr lore), - FreeIn (RetType lore), - FreeIn (Op lore)) => FreeIn (FunDef lore) where - freeIn' (FunDef _ _ rettype params body) = - fvBind (namesFromList $ map paramName params) $ - freeIn' rettype <> freeIn' params <> freeIn' body - -instance (FreeAttr (ExpAttr lore), - FreeAttr (BodyAttr lore), - FreeIn (FParamAttr lore), - FreeIn (LParamAttr lore), - FreeIn (LetAttr lore), - FreeIn (Op lore)) => FreeIn (Lambda lore) where - freeIn' (Lambda params body rettype) = - fvBind (namesFromList $ map paramName params) $ - freeIn' rettype <> freeIn' params <> freeIn' body - -instance (FreeAttr (ExpAttr lore), - FreeAttr (BodyAttr lore), - FreeIn (FParamAttr lore), - FreeIn (LParamAttr lore), - FreeIn (LetAttr lore), - FreeIn (Op lore)) => FreeIn (Body lore) where - freeIn' (Body attr stms res) = - precomputed attr $ freeIn' attr <> freeInStmsAndRes stms res - -instance (FreeAttr (ExpAttr lore), - FreeAttr (BodyAttr lore), - FreeIn (FParamAttr lore), - FreeIn (LParamAttr lore), - FreeIn (LetAttr lore), - FreeIn (Op lore)) => FreeIn (Exp lore) where - freeIn' (DoLoop ctxmerge valmerge form loopbody) = - let (ctxparams, ctxinits) = unzip ctxmerge - (valparams, valinits) = unzip valmerge - bound_here = namesFromList $ M.keys $ - scopeOf form <> - scopeOfFParams (ctxparams ++ valparams) - in fvBind bound_here $ - freeIn' (ctxinits ++ valinits) <> freeIn' form <> - freeIn' (ctxparams ++ valparams) <> freeIn' loopbody - freeIn' e = execState (walkExpM freeWalker e) mempty - -instance (FreeAttr (ExpAttr lore), - FreeAttr (BodyAttr lore), - FreeIn (FParamAttr lore), - FreeIn (LParamAttr lore), - FreeIn (LetAttr lore), - FreeIn (Op lore)) => FreeIn (Stm lore) where - freeIn' (Let pat (StmAux cs attr) e) = - freeIn' cs <> precomputed attr (freeIn' attr <> freeIn' e <> freeIn' pat) - -instance FreeIn (Stm lore) => FreeIn (Stms lore) where - freeIn' = foldMap freeIn' - -instance FreeIn Names where - freeIn' = fvNames - -instance FreeIn Bool where - freeIn' _ = mempty - -instance FreeIn a => FreeIn (Maybe a) where - freeIn' = maybe mempty freeIn' - -instance FreeIn VName where - freeIn' = fvName - -instance FreeIn Ident where - freeIn' = freeIn' . identType - -instance FreeIn SubExp where - freeIn' (Var v) = freeIn' v - freeIn' Constant{} = mempty - -instance FreeIn Space where - freeIn' (ScalarSpace d _) = freeIn' d - freeIn' DefaultSpace = mempty - freeIn' (Space _) = mempty - -instance FreeIn d => FreeIn (ShapeBase d) where - freeIn' = freeIn' . shapeDims - -instance FreeIn d => FreeIn (Ext d) where - freeIn' (Free x) = freeIn' x - freeIn' (Ext _) = mempty - -instance FreeIn shape => FreeIn (TypeBase shape u) where - freeIn' (Array _ shape _) = freeIn' shape - freeIn' (Mem s) = freeIn' s - freeIn' (Prim _) = mempty - -instance FreeIn attr => FreeIn (Param attr) where - freeIn' (Param _ attr) = freeIn' attr - -instance FreeIn attr => FreeIn (PatElemT attr) where - freeIn' (PatElem _ attr) = freeIn' attr - -instance FreeIn (LParamAttr lore) => FreeIn (LoopForm lore) where - freeIn' (ForLoop _ _ bound loop_vars) = freeIn' bound <> freeIn' loop_vars - freeIn' (WhileLoop cond) = freeIn' cond - -instance FreeIn d => FreeIn (DimChange d) where - freeIn' = Data.Foldable.foldMap freeIn' - -instance FreeIn d => FreeIn (DimIndex d) where - freeIn' = Data.Foldable.foldMap freeIn' - -instance FreeIn attr => FreeIn (PatternT attr) where - freeIn' (Pattern context values) = - fvBind bound_here $ freeIn' $ context ++ values - where bound_here = namesFromList $ map patElemName $ context ++ values - -instance FreeIn Certificates where - freeIn' (Certificates cs) = freeIn' cs - -instance FreeIn attr => FreeIn (StmAux attr) where - freeIn' (StmAux cs attr) = freeIn' cs <> freeIn' attr - -instance FreeIn a => FreeIn (IfAttr a) where - freeIn' (IfAttr r _) = freeIn' r - --- | Either return precomputed free names stored in the attribute, or --- the freshly computed names. Relies on lazy evaluation to avoid the --- work. -class FreeIn attr => FreeAttr attr where - precomputed :: attr -> FV -> FV - precomputed _ = id - -instance FreeAttr () where - -instance (FreeAttr a, FreeIn b) => FreeAttr (a,b) where - precomputed (a,_) = precomputed a - -instance FreeAttr a => FreeAttr [a] where - precomputed [] = id - precomputed (a:_) = precomputed a - -instance FreeAttr a => FreeAttr (Maybe a) where - precomputed Nothing = id - precomputed (Just a) = precomputed a - --- | The names bound by the bindings immediately in a 'Body'. -boundInBody :: Body lore -> Names -boundInBody = boundByStms . bodyStms - --- | The names bound by a binding. -boundByStm :: Stm lore -> Names -boundByStm = namesFromList . patternNames . stmPattern - --- | The names bound by the bindings. -boundByStms :: Stms lore -> Names -boundByStms = foldMap boundByStm - --- | The names of the lambda parameters plus the index parameter. -boundByLambda :: Lambda lore -> [VName] -boundByLambda lam = map paramName (lambdaParams lam) diff --git a/src/Futhark/Representation/AST/Attributes/Patterns.hs b/src/Futhark/Representation/AST/Attributes/Patterns.hs deleted file mode 100644 --- a/src/Futhark/Representation/AST/Attributes/Patterns.hs +++ /dev/null @@ -1,101 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} --- | Inspecing and modifying 'Pattern's, function parameters and --- pattern elements. -module Futhark.Representation.AST.Attributes.Patterns - ( - -- * Function parameters - paramIdent - , paramType - , paramDeclType - -- * Pattern elements - , patElemIdent - , patElemType - , setPatElemLore - , patternElements - , patternIdents - , patternContextIdents - , patternValueIdents - , patternNames - , patternValueNames - , patternContextNames - , patternTypes - , patternValueTypes - , patternSize - -- * Pattern construction - , basicPattern - ) - where - -import Futhark.Representation.AST.Syntax -import Futhark.Representation.AST.Attributes.Types (Typed(..), DeclTyped(..)) - --- | The 'Type' of a parameter. -paramType :: Typed attr => Param attr -> Type -paramType = typeOf - --- | The 'DeclType' of a parameter. -paramDeclType :: DeclTyped attr => Param attr -> DeclType -paramDeclType = declTypeOf - --- | An 'Ident' corresponding to a parameter. -paramIdent :: Typed attr => Param attr -> Ident -paramIdent param = Ident (paramName param) (typeOf param) - --- | An 'Ident' corresponding to a pattern element. -patElemIdent :: Typed attr => PatElemT attr -> Ident -patElemIdent pelem = Ident (patElemName pelem) (typeOf pelem) - --- | The type of a name bound by a 'PatElem'. -patElemType :: Typed attr => PatElemT attr -> Type -patElemType = typeOf - --- | Set the lore of a 'PatElem'. -setPatElemLore :: PatElemT oldattr -> newattr -> PatElemT newattr -setPatElemLore pe x = fmap (const x) pe - --- | All pattern elements in the pattern - context first, then values. -patternElements :: PatternT attr -> [PatElemT attr] -patternElements pat = patternContextElements pat ++ patternValueElements pat - --- | Return a list of the 'Ident's bound by the 'Pattern'. -patternIdents :: Typed attr => PatternT attr -> [Ident] -patternIdents pat = patternContextIdents pat ++ patternValueIdents pat - --- | Return a list of the context 'Ident's bound by the 'Pattern'. -patternContextIdents :: Typed attr => PatternT attr -> [Ident] -patternContextIdents = map patElemIdent . patternContextElements - --- | Return a list of the value 'Ident's bound by the 'Pattern'. -patternValueIdents :: Typed attr => PatternT attr -> [Ident] -patternValueIdents = map patElemIdent . patternValueElements - --- | Return a list of the 'Name's bound by the 'Pattern'. -patternNames :: PatternT attr -> [VName] -patternNames = map patElemName . patternElements - --- | Return a list of the 'Name's bound by the context part of the 'Pattern'. -patternContextNames :: PatternT attr -> [VName] -patternContextNames = map patElemName . patternContextElements - --- | Return a list of the 'Name's bound by the value part of the 'Pattern'. -patternValueNames :: PatternT attr -> [VName] -patternValueNames = map patElemName . patternValueElements - --- | Return a list of the 'types's bound by the 'Pattern'. -patternTypes :: Typed attr => PatternT attr -> [Type] -patternTypes = map identType . patternIdents - --- | Return a list of the 'Types's bound by the value part of the 'Pattern'. -patternValueTypes :: Typed attr => PatternT attr -> [Type] -patternValueTypes = map identType . patternValueIdents - --- | Return the number of names bound by the 'Pattern'. -patternSize :: PatternT attr -> Int -patternSize (Pattern context values) = length context + length values - --- | Create a pattern using 'Type' as the attribute. -basicPattern :: [Ident] -> [Ident] -> PatternT Type -basicPattern context values = - Pattern (map patElem context) (map patElem values) - where patElem (Ident name t) = PatElem name t diff --git a/src/Futhark/Representation/AST/Attributes/Ranges.hs b/src/Futhark/Representation/AST/Attributes/Ranges.hs deleted file mode 100644 --- a/src/Futhark/Representation/AST/Attributes/Ranges.hs +++ /dev/null @@ -1,274 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} --- | Utility declarations for performing range analysis. -module Futhark.Representation.AST.Attributes.Ranges - ( Bound - , KnownBound (..) - , boundToScalExp - , minimumBound - , maximumBound - , Range - , unknownRange - , ScalExpRange - , Ranged - , RangeOf (..) - , RangesOf (..) - , expRanges - , RangedOp (..) - , CanBeRanged (..) - ) - where - -import qualified Data.Kind -import qualified Data.Map.Strict as M - -import Futhark.Representation.AST.Attributes -import Futhark.Representation.AST.Syntax -import qualified Futhark.Analysis.ScalExp as SE -import qualified Futhark.Analysis.AlgSimplify as AS -import Futhark.Transform.Substitute -import Futhark.Transform.Rename -import qualified Futhark.Util.Pretty as PP - --- | A known bound on a value. -data KnownBound = VarBound VName - -- ^ Has the same bounds as this variable. VERY - -- IMPORTANT: this variable may be an array, so it - -- cannot be immediately translated to a 'ScalExp'. - | MinimumBound KnownBound KnownBound - -- ^ Bounded by the minimum of these two bounds. - | MaximumBound KnownBound KnownBound - -- ^ Bounded by the maximum of these two bounds. - | ScalarBound SE.ScalExp - -- ^ Bounded by this scalar expression. - deriving (Eq, Ord, Show) - -instance Substitute KnownBound where - substituteNames substs (VarBound name) = - VarBound $ substituteNames substs name - substituteNames substs (MinimumBound b1 b2) = - MinimumBound (substituteNames substs b1) (substituteNames substs b2) - substituteNames substs (MaximumBound b1 b2) = - MaximumBound (substituteNames substs b1) (substituteNames substs b2) - substituteNames substs (ScalarBound se) = - ScalarBound $ substituteNames substs se - -instance Rename KnownBound where - rename = substituteRename - -instance FreeIn KnownBound where - freeIn' (VarBound v) = freeIn' v - freeIn' (MinimumBound b1 b2) = freeIn' b1 <> freeIn' b2 - freeIn' (MaximumBound b1 b2) = freeIn' b1 <> freeIn' b2 - freeIn' (ScalarBound e) = freeIn' e - -instance FreeAttr KnownBound where - precomputed _ = id - -instance PP.Pretty KnownBound where - ppr (VarBound v) = - PP.text "variable " <> PP.ppr v - ppr (MinimumBound b1 b2) = - PP.text "min" <> PP.parens (PP.ppr b1 <> PP.comma PP.<+> PP.ppr b2) - ppr (MaximumBound b1 b2) = - PP.text "max" <> PP.parens (PP.ppr b1 <> PP.comma PP.<+> PP.ppr b2) - ppr (ScalarBound e) = - PP.ppr e - --- | Convert the bound to a scalar expression if possible. This is --- possible for all bounds that do not contain 'VarBound's. -boundToScalExp :: KnownBound -> Maybe SE.ScalExp -boundToScalExp (VarBound _) = Nothing -boundToScalExp (ScalarBound se) = Just se -boundToScalExp (MinimumBound b1 b2) = do - b1' <- boundToScalExp b1 - b2' <- boundToScalExp b2 - return $ SE.MaxMin True [b1', b2'] -boundToScalExp (MaximumBound b1 b2) = do - b1' <- boundToScalExp b1 - b2' <- boundToScalExp b2 - return $ SE.MaxMin False [b1', b2'] - --- | A possibly undefined bound on a value. -type Bound = Maybe KnownBound - --- | Construct a 'MinimumBound' from two possibly known bounds. The --- resulting bound will be unknown unless both of the given 'Bound's --- are known. This may seem counterintuitive, but it actually makes --- sense when you consider the task of combining the lower bounds for --- two different flows of execution (like an @if@ expression). If we --- only have knowledge about one of the branches, this means that we --- have no useful information about the combined lower bound, as the --- other branch may take any value. -minimumBound :: Bound -> Bound -> Bound -minimumBound (Just x) (Just y) = Just $ MinimumBound x y -minimumBound _ _ = Nothing - --- | Like 'minimumBound', but constructs a 'MaximumBound'. -maximumBound :: Bound -> Bound -> Bound -maximumBound (Just x) (Just y) = Just $ MaximumBound x y -maximumBound _ _ = Nothing - --- | Upper and lower bound, both inclusive. -type Range = (Bound, Bound) - --- | A range in which both upper and lower bounds are 'Nothing. -unknownRange :: Range -unknownRange = (Nothing, Nothing) - --- | The range as a pair of scalar expressions. -type ScalExpRange = (Maybe SE.ScalExp, Maybe SE.ScalExp) - --- | The lore has embedded range information. Note that it may not be --- up to date, unless whatever maintains the syntax tree is careful. -type Ranged lore = (Attributes lore, - RangedOp (Op lore), - RangeOf (LetAttr lore), - RangesOf (BodyAttr lore)) - --- | Something that contains range information. -class RangeOf a where - -- | The range of the argument element. - rangeOf :: a -> Range - -instance RangeOf Range where - rangeOf = id - -instance RangeOf attr => RangeOf (PatElemT attr) where - rangeOf = rangeOf . patElemAttr - -instance RangeOf SubExp where - rangeOf se = (Just lower, Just upper) - where (lower, upper) = subExpKnownRange se - --- | Something that contains range information for several things, --- most notably 'Body' or 'Pattern'. -class RangesOf a where - -- | The ranges of the argument. - rangesOf :: a -> [Range] - -instance RangeOf a => RangesOf [a] where - rangesOf = map rangeOf - -instance RangeOf attr => RangesOf (PatternT attr) where - rangesOf = map rangeOf . patternElements - -instance Ranged lore => RangesOf (Body lore) where - rangesOf = rangesOf . bodyAttr - -subExpKnownRange :: SubExp -> (KnownBound, KnownBound) -subExpKnownRange (Var v) = - (VarBound v, - VarBound v) -subExpKnownRange (Constant val) = - (ScalarBound $ SE.Val val, - ScalarBound $ SE.Val val) - --- | The range of a scalar expression. -scalExpRange :: SE.ScalExp -> Range -scalExpRange se = - (Just $ ScalarBound se, Just $ ScalarBound se) - -primOpRanges :: BasicOp -> [Range] -primOpRanges (SubExp se) = - [rangeOf se] - -primOpRanges (BinOp (Add t _) x y) = - [scalExpRange $ SE.SPlus (SE.subExpToScalExp x $ IntType t) (SE.subExpToScalExp y $ IntType t)] -primOpRanges (BinOp (Sub t _) x y) = - [scalExpRange $ SE.SMinus (SE.subExpToScalExp x $ IntType t) (SE.subExpToScalExp y $ IntType t)] -primOpRanges (BinOp (Mul t _) x y) = - [scalExpRange $ SE.STimes (SE.subExpToScalExp x $ IntType t) (SE.subExpToScalExp y $ IntType t)] -primOpRanges (BinOp (SDiv t) x y) = - [scalExpRange $ SE.SDiv (SE.subExpToScalExp x $ IntType t) (SE.subExpToScalExp y $ IntType t)] - -primOpRanges (ConvOp (SExt from to) x) - | from < to = [rangeOf x] - -primOpRanges (ConvOp (BToI it) _) = - [(Just $ ScalarBound $ SE.Val $ IntValue $ intValue it (0::Int), - Just $ ScalarBound $ SE.Val $ IntValue $ intValue it (1::Int))] - -primOpRanges (Iota n x s Int32) = - [(Just $ ScalarBound x', - Just $ ScalarBound $ x' + (n' - 1) * s')] - where n' = case n of - Var v -> SE.Id v $ IntType Int32 - Constant val -> SE.Val val - x' = case x of - Var v -> SE.Id v $ IntType Int32 - Constant val -> SE.Val val - s' = case s of - Var v -> SE.Id v $ IntType Int32 - Constant val -> SE.Val val -primOpRanges (Replicate _ v) = - [rangeOf v] -primOpRanges (Rearrange _ v) = - [rangeOf $ Var v] -primOpRanges (Copy se) = - [rangeOf $ Var se] -primOpRanges (Index v _) = - [rangeOf $ Var v] -primOpRanges (ArrayLit (e:es) _) = - [(Just lower, Just upper)] - where (e_lower, e_upper) = subExpKnownRange e - (es_lower, es_upper) = unzip $ map subExpKnownRange es - lower = foldl MinimumBound e_lower es_lower - upper = foldl MaximumBound e_upper es_upper -primOpRanges _ = - [unknownRange] - --- | Ranges of the value parts of the expression. -expRanges :: Ranged lore => - Exp lore -> [Range] -expRanges (BasicOp op) = - primOpRanges op -expRanges (If _ tbranch fbranch _) = - zip - (zipWith minimumBound t_lower f_lower) - (zipWith maximumBound t_upper f_upper) - where (t_lower, t_upper) = unzip $ rangesOf tbranch - (f_lower, f_upper) = unzip $ rangesOf fbranch -expRanges (DoLoop ctxmerge valmerge (ForLoop i Int32 iterations _) body) = - zipWith returnedRange valmerge $ rangesOf body - where bound_in_loop = - namesFromList $ i : map (paramName . fst) (ctxmerge++valmerge) ++ - concatMap (patternNames . stmPattern) (bodyStms body) - - returnedRange mergeparam (lower, upper) = - (returnedBound mergeparam lower, - returnedBound mergeparam upper) - - returnedBound (param, mergeinit) (Just bound) - | paramType param == Prim (IntType Int32), - Just bound' <- boundToScalExp bound, - let se_diff = - AS.simplify (SE.SMinus (SE.Id (paramName param) $ IntType Int32) bound') M.empty, - namesIntersect bound_in_loop $ freeIn se_diff = - Just $ ScalarBound $ SE.SPlus (SE.subExpToScalExp mergeinit $ IntType Int32) $ - SE.STimes se_diff $ SE.MaxMin False - [SE.subExpToScalExp iterations $ IntType Int32, 0] - returnedBound _ _ = Nothing -expRanges (Op ranges) = opRanges ranges -expRanges e = - replicate (expExtTypeSize e) unknownRange - -class IsOp op => RangedOp op where - opRanges :: op -> [Range] - -instance RangedOp () where - opRanges () = [] - -class RangedOp (OpWithRanges op) => - CanBeRanged op where - type OpWithRanges op :: Data.Kind.Type - removeOpRanges :: OpWithRanges op -> op - addOpRanges :: op -> OpWithRanges op - -instance CanBeRanged () where - type OpWithRanges () = () - removeOpRanges = id - addOpRanges = id diff --git a/src/Futhark/Representation/AST/Attributes/Rearrange.hs b/src/Futhark/Representation/AST/Attributes/Rearrange.hs deleted file mode 100644 --- a/src/Futhark/Representation/AST/Attributes/Rearrange.hs +++ /dev/null @@ -1,108 +0,0 @@ --- | A rearrangement is a generalisation of transposition, where the --- dimensions are arbitrarily permuted. -module Futhark.Representation.AST.Attributes.Rearrange - ( rearrangeShape - , rearrangeInverse - , rearrangeReach - , rearrangeCompose - , isPermutationOf - , transposeIndex - , isMapTranspose - ) where - -import Data.List (sortOn, tails) - -import Futhark.Util - --- | Calculate the given permutation of the list. It is an error if --- the permutation goes out of bounds. -rearrangeShape :: [Int] -> [a] -> [a] -rearrangeShape perm l = map pick perm - where pick i - | 0 <= i, i < n = l!!i - | otherwise = - error $ show perm ++ " is not a valid permutation for input." - n = length l - --- | Produce the inverse permutation. -rearrangeInverse :: [Int] -> [Int] -rearrangeInverse perm = map snd $ sortOn fst $ zip perm [0..] - --- | Return the first dimension not affected by the permutation. For --- example, the permutation @[1,0,2]@ would return @2@. -rearrangeReach :: [Int] -> Int -rearrangeReach perm = case dropWhile (uncurry (/=)) $ zip (tails perm) (tails [0..n-1]) of - [] -> n + 1 - (perm',_):_ -> n - length perm' - where n = length perm - --- | Compose two permutations, with the second given permutation being --- applied first. -rearrangeCompose :: [Int] -> [Int] -> [Int] -rearrangeCompose = rearrangeShape - --- | Check whether the first list is a permutation of the second, and --- if so, return the permutation. This will also find identity --- permutations (i.e. the lists are the same) The implementation is --- naive and slow. -isPermutationOf :: Eq a => [a] -> [a] -> Maybe [Int] -isPermutationOf l1 l2 = - case mapAccumLM (pick 0) (map Just l2) l1 of - Just (l2', perm) - | all (==Nothing) l2' -> Just perm - _ -> Nothing - where pick :: Eq a => Int -> [Maybe a] -> a -> Maybe ([Maybe a], Int) - pick _ [] _ = Nothing - pick i (x:xs) y - | Just y == x = Just (Nothing : xs, i) - | otherwise = do - (xs', v) <- pick (i+1) xs y - return (x : xs', v) - --- | If @l@ is an index into the array @a@, then @transposeIndex k n --- l@ is an index to the same element in the array @transposeArray k n --- a@. -transposeIndex :: Int -> Int -> [a] -> [a] -transposeIndex k n l - | k + n >= length l = - let n' = ((k + n) `mod` length l)-k - in transposeIndex k n' l - | n < 0, - (pre,needle:end) <- splitAt k l, - (beg,mid) <- splitAt (length pre+n) pre = - beg ++ [needle] ++ mid ++ end - | (beg,needle:post) <- splitAt k l, - (mid,end) <- splitAt n post = - beg ++ mid ++ [needle] ++ end - | otherwise = l - --- | If @perm@ is conceptually a map of a transposition, --- @isMapTranspose perm@ returns the number of dimensions being mapped --- and the number dimension being transposed. For example, we can --- consider the permutation @[0,1,4,5,2,3]@ as a map of a transpose, --- by considering dimensions @[0,1]@, @[4,5]@, and @[2,3]@ as single --- dimensions each. --- --- If the input is not a valid permutation, then the result is --- undefined. -isMapTranspose :: [Int] -> Maybe (Int, Int, Int) -isMapTranspose perm - | posttrans == [length mapped..length mapped+length posttrans-1], - not $ null pretrans, not $ null posttrans = - Just (length mapped, length pretrans, length posttrans) - | otherwise = - Nothing - where (mapped, notmapped) = findIncreasingFrom 0 perm - (pretrans, posttrans) = findTransposed notmapped - - findIncreasingFrom x (i:is) - | i == x = - let (js, ps) = findIncreasingFrom (x+1) is - in (i : js, ps) - findIncreasingFrom _ is = - ([], is) - - findTransposed [] = - ([], []) - findTransposed (i:is) = - findIncreasingFrom i (i:is) diff --git a/src/Futhark/Representation/AST/Attributes/Reshape.hs b/src/Futhark/Representation/AST/Attributes/Reshape.hs deleted file mode 100644 --- a/src/Futhark/Representation/AST/Attributes/Reshape.hs +++ /dev/null @@ -1,175 +0,0 @@ -module Futhark.Representation.AST.Attributes.Reshape - ( - -- * Basic tools - newDim - , newDims - , newShape - - -- * Construction - , shapeCoerce - , repeatShapes - - -- * Execution - , reshapeOuter - , reshapeInner - , repeatDims - - -- * Inspection - , shapeCoercion - - -- * Simplification - , fuseReshape - , informReshape - - -- * Shape calculations - , reshapeIndex - , flattenIndex - , unflattenIndex - , sliceSizes - ) - where - -import Data.Foldable - -import Prelude hiding (sum, product, quot) - -import Futhark.Representation.AST.Attributes.Types -import Futhark.Representation.AST.Syntax -import Futhark.Util.IntegralExp - --- | The new dimension. -newDim :: DimChange d -> d -newDim (DimCoercion se) = se -newDim (DimNew se) = se - --- | The new dimensions resulting from a reshape operation. -newDims :: ShapeChange d -> [d] -newDims = map newDim - --- | The new shape resulting from a reshape operation. -newShape :: ShapeChange SubExp -> Shape -newShape = Shape . newDims - --- ^ Construct a 'Reshape' where all dimension changes are --- 'DimCoercion's. -shapeCoerce :: [SubExp] -> VName -> Exp lore -shapeCoerce newdims arr = - BasicOp $ Reshape (map DimCoercion newdims) arr - --- | Construct a pair suitable for a 'Repeat'. -repeatShapes :: [Shape] -> Type -> ([Shape], Shape) -repeatShapes shapes t = - case splitAt t_rank shapes of - (outer_shapes, [inner_shape]) -> - (outer_shapes, inner_shape) - _ -> - (shapes ++ replicate (length shapes - t_rank) (Shape []), Shape []) - where t_rank = arrayRank t - --- | Modify the shape of an array type as 'Repeat' would do -repeatDims :: [Shape] -> Shape -> Type -> Type -repeatDims shape innershape = modifyArrayShape repeatDims' - where repeatDims' (Shape ds) = - Shape $ concat (zipWith (++) (map shapeDims shape) (map pure ds)) ++ - shapeDims innershape - --- | @reshapeOuter newshape n oldshape@ returns a 'Reshape' expression --- that replaces the outer @n@ dimensions of @oldshape@ with @newshape@. -reshapeOuter :: ShapeChange SubExp -> Int -> Shape -> ShapeChange SubExp -reshapeOuter newshape n oldshape = - newshape ++ map coercion_or_new (drop n (shapeDims oldshape)) - where coercion_or_new - | length newshape == n = DimCoercion - | otherwise = DimNew - --- | @reshapeInner newshape n oldshape@ returns a 'Reshape' expression --- that replaces the inner @m-n@ dimensions (where @m@ is the rank of --- @oldshape@) of @src@ with @newshape@. -reshapeInner :: ShapeChange SubExp -> Int -> Shape -> ShapeChange SubExp -reshapeInner newshape n oldshape = - map coercion_or_new (take n (shapeDims oldshape)) ++ newshape - where coercion_or_new - | length newshape == m-n = DimCoercion - | otherwise = DimNew - m = shapeRank oldshape - --- | If the shape change is nothing but shape coercions, return the new dimensions. Otherwise, return --- 'Nothing'. -shapeCoercion :: ShapeChange d -> Maybe [d] -shapeCoercion = mapM dimCoercion - where dimCoercion (DimCoercion d) = Just d - dimCoercion (DimNew _) = Nothing - --- | @fuseReshape s1 s2@ creates a new 'ShapeChange' that is --- semantically the same as first applying @s1@ and then @s2@. This --- may take advantage of properties of 'DimCoercion' versus 'DimNew' --- to preserve information. -fuseReshape :: Eq d => ShapeChange d -> ShapeChange d -> ShapeChange d -fuseReshape s1 s2 - | length s1 == length s2 = - zipWith comb s1 s2 - where comb (DimNew _) (DimCoercion d2) = - DimNew d2 - comb (DimCoercion d1) (DimNew d2) - | d1 == d2 = DimCoercion d2 - | otherwise = DimNew d2 - comb _ d2 = - d2 --- TODO: intelligently handle case where s1 is a prefix of s2. -fuseReshape _ s2 = s2 - --- | Given concrete information about the shape of the source array, --- convert some 'DimNew's into 'DimCoercion's. -informReshape :: Eq d => [d] -> ShapeChange d -> ShapeChange d -informReshape shape sc - | length shape == length sc = - zipWith inform shape sc - where inform d1 (DimNew d2) - | d1 == d2 = DimCoercion d2 - inform _ dc = - dc -informReshape _ sc = sc - --- | @reshapeIndex to_dims from_dims is@ transforms the index list --- @is@ (which is into an array of shape @from_dims@) into an index --- list @is'@, which is into an array of shape @to_dims@. @is@ must --- have the same length as @from_dims@, and @is'@ will have the same --- length as @to_dims@. -reshapeIndex :: IntegralExp num => - [num] -> [num] -> [num] -> [num] -reshapeIndex to_dims from_dims is = - unflattenIndex to_dims $ flattenIndex from_dims is - --- | @unflattenIndex dims i@ computes a list of indices into an array --- with dimension @dims@ given the flat index @i@. The resulting list --- will have the same size as @dims@. -unflattenIndex :: IntegralExp num => - [num] -> num -> [num] -unflattenIndex = unflattenIndexFromSlices . drop 1 . sliceSizes - -unflattenIndexFromSlices :: IntegralExp num => - [num] -> num -> [num] -unflattenIndexFromSlices [] _ = [] -unflattenIndexFromSlices (size : slices) i = - (i `quot` size) : unflattenIndexFromSlices slices (i - (i `quot` size) * size) - --- | @flattenIndex dims is@ computes the flat index of @is@ into an --- array with dimensions @dims@. The length of @dims@ and @is@ must --- be the same. -flattenIndex :: IntegralExp num => - [num] -> [num] -> num -flattenIndex dims is = - sum $ zipWith (*) is slicesizes - where slicesizes = drop 1 $ sliceSizes dims - --- | Given a length @n@ list of dimensions @dims@, @sizeSizes dims@ --- will compute a length @n+1@ list of the size of each possible array --- slice. The first element of this list will be the product of --- @dims@, and the last element will be 1. -sliceSizes :: IntegralExp num => - [num] -> [num] -sliceSizes [] = [1] -sliceSizes (n:ns) = - product (n : ns) : sliceSizes ns - -{- HLINT ignore sliceSizes -} diff --git a/src/Futhark/Representation/AST/Attributes/Scope.hs b/src/Futhark/Representation/AST/Attributes/Scope.hs deleted file mode 100644 --- a/src/Futhark/Representation/AST/Attributes/Scope.hs +++ /dev/null @@ -1,217 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE StandaloneDeriving #-} --- | This module defines the concept of a type environment as a --- mapping from variable names to 'Type's. Convenience facilities are --- also provided to communicate that some monad or applicative functor --- maintains type information. -module Futhark.Representation.AST.Attributes.Scope - ( HasScope (..) - , NameInfo (..) - , LocalScope (..) - , Scope - , Scoped(..) - , inScopeOf - , scopeOfLParams - , scopeOfFParams - , scopeOfPattern - , scopeOfPatElem - - , SameScope - , castScope - , castNameInfo - - -- * Extended type environment - , ExtendedScope - , extendedScope - ) where - -import Control.Monad.Except -import Control.Monad.Reader -import qualified Control.Monad.RWS.Strict -import qualified Control.Monad.RWS.Lazy -import qualified Data.Map.Strict as M - -import Futhark.Representation.AST.Annotations -import Futhark.Representation.AST.Syntax -import Futhark.Representation.AST.Attributes.Types -import Futhark.Representation.AST.Attributes.Patterns -import Futhark.Representation.AST.Pretty () - --- | How some name in scope was bound. -data NameInfo lore = LetInfo (LetAttr lore) - | FParamInfo (FParamAttr lore) - | LParamInfo (LParamAttr lore) - | IndexInfo IntType - -deriving instance Annotations lore => Show (NameInfo lore) - -instance Annotations lore => Typed (NameInfo lore) where - typeOf (LetInfo attr) = typeOf attr - typeOf (FParamInfo attr) = typeOf attr - typeOf (LParamInfo attr) = typeOf attr - typeOf (IndexInfo it) = Prim $ IntType it - --- | A scope is a mapping from variable names to information about --- that name. -type Scope lore = M.Map VName (NameInfo lore) - --- | The class of applicative functors (or more common in practice: --- monads) that permit the lookup of variable types. A default method --- for 'lookupType' exists, which is sufficient (if not always --- maximally efficient, and using 'error' to fail) when 'askScope' --- is defined. -class (Applicative m, Annotations lore) => HasScope lore m | m -> lore where - -- | Return the type of the given variable, or fail if it is not in - -- the type environment. - lookupType :: VName -> m Type - lookupType = fmap typeOf . lookupInfo - - -- | Return the info of the given variable, or fail if it is not in - -- the type environment. - lookupInfo :: VName -> m (NameInfo lore) - lookupInfo name = - asksScope (M.findWithDefault notFound name) - where notFound = - error $ "Scope.lookupInfo: Name " ++ pretty name ++ - " not found in type environment." - - -- | Return the type environment contained in the applicative - -- functor. - askScope :: m (Scope lore) - - -- | Return the result of applying some function to the type - -- environment. - asksScope :: (Scope lore -> a) -> m a - asksScope f = f <$> askScope - -instance (Applicative m, Monad m, Annotations lore) => - HasScope lore (ReaderT (Scope lore) m) where - askScope = ask - -instance (Monad m, HasScope lore m) => HasScope lore (ExceptT e m) where - askScope = lift askScope - -instance (Applicative m, Monad m, Monoid w, Annotations lore) => - HasScope lore (Control.Monad.RWS.Strict.RWST (Scope lore) w s m) where - askScope = ask - -instance (Applicative m, Monad m, Monoid w, Annotations lore) => - HasScope lore (Control.Monad.RWS.Lazy.RWST (Scope lore) w s m) where - askScope = ask - --- | The class of monads that not only provide a 'Scope', but also --- the ability to locally extend it. A 'Reader' containing a --- 'Scope' is the prototypical example of such a monad. -class (HasScope lore m, Monad m) => LocalScope lore m where - -- | Run a computation with an extended type environment. Note that - -- this is intended to *add* to the current type environment, it - -- does not replace it. - localScope :: Scope lore -> m a -> m a - -instance (Monad m, LocalScope lore m) => LocalScope lore (ExceptT e m) where - localScope = mapExceptT . localScope - -instance (Applicative m, Monad m, Annotations lore) => - LocalScope lore (ReaderT (Scope lore) m) where - localScope = local . M.union - -instance (Applicative m, Monad m, Monoid w, Annotations lore) => - LocalScope lore (Control.Monad.RWS.Strict.RWST (Scope lore) w s m) where - localScope = local . M.union - -instance (Applicative m, Monad m, Monoid w, Annotations lore) => - LocalScope lore (Control.Monad.RWS.Lazy.RWST (Scope lore) w s m) where - localScope = local . M.union - --- | The class of things that can provide a scope. There is no --- overarching rule for what this means. For a 'Stm', it is the --- corresponding pattern. For a 'Lambda', is is the parameters --- (including index). -class Scoped lore a | a -> lore where - scopeOf :: a -> Scope lore - -inScopeOf :: (Scoped lore a, LocalScope lore m) => a -> m b -> m b -inScopeOf = localScope . scopeOf - -instance Scoped lore a => Scoped lore [a] where - scopeOf = mconcat . map scopeOf - -instance Scoped lore (Stms lore) where - scopeOf = foldMap scopeOf - -instance Scoped lore (Stm lore) where - scopeOf = scopeOfPattern . stmPattern - -instance Scoped lore (FunDef lore) where - scopeOf = scopeOfFParams . funDefParams - -instance Scoped lore (VName, NameInfo lore) where - scopeOf = uncurry M.singleton - -instance Scoped lore (LoopForm lore) where - scopeOf (WhileLoop _) = mempty - scopeOf (ForLoop i it _ xs) = - M.insert i (IndexInfo it) $ scopeOfLParams (map fst xs) - -scopeOfPattern :: LetAttr lore ~ attr => PatternT attr -> Scope lore -scopeOfPattern = - mconcat . map scopeOfPatElem . patternElements - -scopeOfPatElem :: LetAttr lore ~ attr => PatElemT attr -> Scope lore -scopeOfPatElem (PatElem name attr) = M.singleton name $ LetInfo attr - -scopeOfLParams :: LParamAttr lore ~ attr => - [Param attr] -> Scope lore -scopeOfLParams = M.fromList . map f - where f param = (paramName param, LParamInfo $ paramAttr param) - -scopeOfFParams :: FParamAttr lore ~ attr => - [Param attr] -> Scope lore -scopeOfFParams = M.fromList . map f - where f param = (paramName param, FParamInfo $ paramAttr param) - -instance Scoped lore (Lambda lore) where - scopeOf lam = scopeOfLParams $ lambdaParams lam - -type SameScope lore1 lore2 = (LetAttr lore1 ~ LetAttr lore2, - FParamAttr lore1 ~ FParamAttr lore2, - LParamAttr lore1 ~ LParamAttr lore2) - --- | If two scopes are really the same, then you can convert one to --- the other. -castScope :: SameScope fromlore tolore => - Scope fromlore -> Scope tolore -castScope = M.map castNameInfo - -castNameInfo :: SameScope fromlore tolore => - NameInfo fromlore -> NameInfo tolore -castNameInfo (LetInfo attr) = LetInfo attr -castNameInfo (FParamInfo attr) = FParamInfo attr -castNameInfo (LParamInfo attr) = LParamInfo attr -castNameInfo (IndexInfo it) = IndexInfo it - --- | A monad transformer that carries around an extended 'Scope'. --- Its 'lookupType' method will first look in the extended 'Scope', --- and then use the 'lookupType' method of the underlying monad. -newtype ExtendedScope lore m a = ExtendedScope (ReaderT (Scope lore) m a) - deriving (Functor, Applicative, Monad, - MonadReader (Scope lore)) - -instance (HasScope lore m, Monad m) => - HasScope lore (ExtendedScope lore m) where - lookupType name = do - res <- asks $ fmap typeOf . M.lookup name - maybe (ExtendedScope $ lift $ lookupType name) return res - askScope = asks M.union <*> ExtendedScope (lift askScope) - --- | Run a computation in the extended type environment. -extendedScope :: ExtendedScope lore m a - -> Scope lore - -> m a -extendedScope (ExtendedScope m) = runReaderT m diff --git a/src/Futhark/Representation/AST/Attributes/TypeOf.hs b/src/Futhark/Representation/AST/Attributes/TypeOf.hs deleted file mode 100644 --- a/src/Futhark/Representation/AST/Attributes/TypeOf.hs +++ /dev/null @@ -1,169 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} --- | This module provides facilities for obtaining the types of --- various Futhark constructs. Typically, you will need to execute --- these in a context where type information is available as a --- 'Scope'; usually by using a monad that is an instance of --- 'HasScope'. The information is returned as a list of 'ExtType' --- values - one for each of the values the Futhark construct returns. --- Some constructs (such as subexpressions) can produce only a single --- value, and their typing functions hence do not return a list. --- --- Some representations may have more specialised facilities enabling --- even more information - for example, --- "Futhark.Representation.Mem" exposes functionality for --- also obtaining information about the storage location of results. -module Futhark.Representation.AST.Attributes.TypeOf - ( - expExtType - , expExtTypeSize - , subExpType - , bodyExtType - , primOpType - , mapType - - -- * Return type - , module Futhark.Representation.AST.RetType - -- * Type environment - , module Futhark.Representation.AST.Attributes.Scope - - -- * Extensibility - , TypedOp(..) - ) - where - -import Data.Maybe -import qualified Data.Set as S - -import Futhark.Representation.AST.Syntax -import Futhark.Representation.AST.Attributes.Reshape -import Futhark.Representation.AST.Attributes.Types -import Futhark.Representation.AST.Attributes.Patterns -import Futhark.Representation.AST.Attributes.Constants -import Futhark.Representation.AST.RetType -import Futhark.Representation.AST.Attributes.Scope - --- | The type of a subexpression. -subExpType :: HasScope t m => SubExp -> m Type -subExpType (Constant val) = pure $ Prim $ primValueType val -subExpType (Var name) = lookupType name - --- | @mapType f arrts@ wraps each element in the return type of @f@ in --- an array with size equal to the outermost dimension of the first --- element of @arrts@. -mapType :: SubExp -> Lambda lore -> [Type] -mapType outersize f = [ arrayOf t (Shape [outersize]) NoUniqueness - | t <- lambdaReturnType f ] - --- | The type of a primitive operation. -primOpType :: HasScope lore m => BasicOp -> m [Type] -primOpType (SubExp se) = - pure <$> subExpType se -primOpType (Opaque se) = - pure <$> subExpType se -primOpType (ArrayLit es rt) = - pure [arrayOf rt (Shape [n]) NoUniqueness] - where n = Constant (value (length es)) -primOpType (BinOp bop _ _) = - pure [Prim $ binOpType bop] -primOpType (UnOp _ x) = - pure <$> subExpType x -primOpType CmpOp{} = - pure [Prim Bool] -primOpType (ConvOp conv _) = - pure [Prim $ snd $ convOpType conv] -primOpType (Index ident slice) = - result <$> lookupType ident - where result t = [Prim (elemType t) `arrayOfShape` shape] - shape = Shape $ mapMaybe dimSize slice - dimSize (DimSlice _ d _) = Just d - dimSize DimFix{} = Nothing -primOpType (Update src _ _) = - pure <$> lookupType src -primOpType (Iota n _ _ et) = - pure [arrayOf (Prim (IntType et)) (Shape [n]) NoUniqueness] -primOpType (Replicate (Shape []) e) = - pure <$> subExpType e -primOpType (Repeat shape innershape v) = - pure . repeatDims shape innershape <$> lookupType v -primOpType (Replicate shape e) = - pure . flip arrayOfShape shape <$> subExpType e -primOpType (Scratch t shape) = - pure [arrayOf (Prim t) (Shape shape) NoUniqueness] -primOpType (Reshape [] e) = - result <$> lookupType e - where result t = [Prim $ elemType t] -primOpType (Reshape shape e) = - result <$> lookupType e - where result t = [t `setArrayShape` newShape shape] -primOpType (Rearrange perm e) = - result <$> lookupType e - where result t = [rearrangeType perm t] -primOpType (Rotate _ e) = - pure <$> lookupType e -primOpType (Concat i x _ ressize) = - result <$> lookupType x - where result xt = [setDimSize i xt ressize] -primOpType (Copy v) = - pure <$> lookupType v -primOpType (Manifest _ v) = - pure <$> lookupType v -primOpType Assert{} = - pure [Prim Cert] - --- | The type of an expression. -expExtType :: (HasScope lore m, TypedOp (Op lore)) => - Exp lore -> m [ExtType] -expExtType (Apply _ _ rt _) = pure $ map fromDecl $ retTypeValues rt -expExtType (If _ _ _ rt) = pure $ bodyTypeValues $ ifReturns rt -expExtType (DoLoop ctxmerge valmerge _ _) = - pure $ loopExtType (map (paramIdent . fst) ctxmerge) (map (paramIdent . fst) valmerge) -expExtType (BasicOp op) = staticShapes <$> primOpType op -expExtType (Op op) = opType op - --- | The number of values returned by an expression. -expExtTypeSize :: (Annotations lore, TypedOp (Op lore)) => - Exp lore -> Int -expExtTypeSize = length . feelBad . expExtType - --- FIXME, this is a horrible quick hack. -newtype FeelBad lore a = FeelBad { feelBad :: a } - -instance Functor (FeelBad lore) where - fmap f = FeelBad . f . feelBad - -instance Applicative (FeelBad lore) where - pure = FeelBad - f <*> x = FeelBad $ feelBad f $ feelBad x - -instance Annotations lore => HasScope lore (FeelBad lore) where - lookupType = const $ pure $ Prim $ IntType Int32 - askScope = pure mempty - --- | The type of a body. Watch out: this only works for the --- degenerate case where the body does not already return its context. -bodyExtType :: (HasScope lore m, Monad m) => - Body lore -> m [ExtType] -bodyExtType (Body _ stms res) = - existentialiseExtTypes bound . staticShapes <$> - extendedScope (traverse subExpType res) bndscope - where bndscope = scopeOf stms - boundInLet (Let pat _ _) = S.fromList $ patternNames pat - bound = S.toList $ foldMap boundInLet stms - --- | Given the context and value merge parameters of a Futhark @loop@, --- produce the return type. -loopExtType :: [Ident] -> [Ident] -> [ExtType] -loopExtType ctx val = - existentialiseExtTypes inaccessible $ staticShapes $ map identType val - where inaccessible = map identName ctx - --- | Any operation must define an instance of this class, which --- describes the type of the operation (at the value level). -class TypedOp op where - opType :: HasScope t m => op -> m [ExtType] - -instance TypedOp () where - opType () = pure [] diff --git a/src/Futhark/Representation/AST/Attributes/Types.hs b/src/Futhark/Representation/AST/Attributes/Types.hs deleted file mode 100644 --- a/src/Futhark/Representation/AST/Attributes/Types.hs +++ /dev/null @@ -1,542 +0,0 @@ -{-# LANGUAGE FlexibleContexts, FlexibleInstances #-} --- | Functions for inspecting and constructing various types. -module Futhark.Representation.AST.Attributes.Types - ( - rankShaped - , arrayRank - , arrayShape - , modifyArrayShape - , setArrayShape - , existential - , uniqueness - , unique - , staticShapes - , staticShapes1 - , primType - - , arrayOf - , arrayOfRow - , arrayOfShape - , setOuterSize - , setDimSize - , setOuterDim - , setDim - , setArrayDims - , peelArray - , stripArray - , arrayDims - , arrayExtDims - , shapeSize - , arraySize - , arraysSize - , rowType - , elemType - - , transposeType - , rearrangeType - - , diet - - , subtypeOf - , subtypesOf - - , toDecl - , fromDecl - - , isExt - , extractShapeContext - , shapeContext - , hasStaticShape - , generaliseExtTypes - , existentialiseExtTypes - , shapeMapping - , shapeExtMapping - - -- * Abbreviations - , int8, int16, int32, int64 - , float32, float64 - - -- * The Typed typeclass - , Typed (..) - , DeclTyped (..) - , ExtTyped (..) - , DeclExtTyped (..) - , SetType (..) - , FixExt (..) - ) - where - -import Control.Monad.State -import Data.Maybe -import Data.List (elemIndex, foldl') -import qualified Data.Set as S -import qualified Data.Map.Strict as M - -import Futhark.Representation.AST.Syntax.Core -import Futhark.Representation.AST.Attributes.Constants -import Futhark.Representation.AST.Attributes.Rearrange - --- | Remove shape information from a type. -rankShaped :: ArrayShape shape => TypeBase shape u -> TypeBase Rank u -rankShaped (Array et sz u) = Array et (Rank $ shapeRank sz) u -rankShaped (Prim et) = Prim et -rankShaped (Mem space) = Mem space - --- | Return the dimensionality of a type. For non-arrays, this is --- zero. For a one-dimensional array it is one, for a two-dimensional --- it is two, and so forth. -arrayRank :: ArrayShape shape => TypeBase shape u -> Int -arrayRank = shapeRank . arrayShape - --- | Return the shape of a type - for non-arrays, this is the --- 'mempty'. -arrayShape :: ArrayShape shape => TypeBase shape u -> shape -arrayShape (Array _ ds _) = ds -arrayShape _ = mempty - --- | Modify the shape of an array - for non-arrays, this does nothing. -modifyArrayShape :: ArrayShape newshape => - (oldshape -> newshape) - -> TypeBase oldshape u - -> TypeBase newshape u -modifyArrayShape f (Array t ds u) - | shapeRank ds' == 0 = Prim t - | otherwise = Array t (f ds) u - where ds' = f ds -modifyArrayShape _ (Prim t) = Prim t -modifyArrayShape _ (Mem space) = Mem space - --- | Set the shape of an array. If the given type is not an --- array, return the type unchanged. -setArrayShape :: ArrayShape newshape => - TypeBase oldshape u - -> newshape - -> TypeBase newshape u -setArrayShape t ds = modifyArrayShape (const ds) t - --- | True if the given type has a dimension that is existentially sized. -existential :: ExtType -> Bool -existential = any ext . shapeDims . arrayShape - where ext (Ext _) = True - ext (Free _) = False - --- | Return the uniqueness of a type. -uniqueness :: TypeBase shape Uniqueness -> Uniqueness -uniqueness (Array _ _ u) = u -uniqueness _ = Nonunique - --- | @unique t@ is 'True' if the type of the argument is unique. -unique :: TypeBase shape Uniqueness -> Bool -unique = (==Unique) . uniqueness - --- | Convert types with non-existential shapes to types with --- non-existential shapes. Only the representation is changed, so all --- the shapes will be 'Free'. -staticShapes :: [TypeBase Shape u] -> [TypeBase ExtShape u] -staticShapes = map staticShapes1 - --- | As 'staticShapes', but on a single type. -staticShapes1 :: TypeBase Shape u -> TypeBase ExtShape u -staticShapes1 (Prim bt) = - Prim bt -staticShapes1 (Array bt (Shape shape) u) = - Array bt (Shape $ map Free shape) u -staticShapes1 (Mem space) = - Mem space - --- | @arrayOf t s u@ constructs an array type. The convenience --- compared to using the 'Array' constructor directly is that @t@ can --- itself be an array. If @t@ is an @n@-dimensional array, and @s@ is --- a list of length @n@, the resulting type is of an @n+m@ dimensions. --- The uniqueness of the new array will be @u@, no matter the --- uniqueness of @t@. If the shape @s@ has rank 0, then the @t@ will --- be returned, although if it is an array, with the uniqueness --- changed to @u@. -arrayOf :: ArrayShape shape => - TypeBase shape u_unused -> shape -> u -> TypeBase shape u -arrayOf (Array et size1 _) size2 u = - Array et (size2 <> size1) u -arrayOf (Prim et) s _ - | 0 <- shapeRank s = Prim et -arrayOf (Prim et) size u = - Array et size u -arrayOf Mem{} _ _ = - error "arrayOf Mem" - --- | Construct an array whose rows are the given type, and the outer --- size is the given dimension. This is just a convenient wrapper --- around 'arrayOf'. -arrayOfRow :: ArrayShape (ShapeBase d) => - TypeBase (ShapeBase d) NoUniqueness - -> d - -> TypeBase (ShapeBase d) NoUniqueness -arrayOfRow t size = arrayOf t (Shape [size]) NoUniqueness - --- | Construct an array whose rows are the given type, and the outer --- size is the given 'Shape'. This is just a convenient wrapper --- around 'arrayOf'. -arrayOfShape :: Type -> Shape -> Type -arrayOfShape t shape = arrayOf t shape NoUniqueness - --- | Set the dimensions of an array. If the given type is not an --- array, return the type unchanged. -setArrayDims :: TypeBase oldshape u -> [SubExp] -> TypeBase Shape u -setArrayDims t dims = t `setArrayShape` Shape dims - --- | Replace the size of the outermost dimension of an array. If the --- given type is not an array, it is returned unchanged. -setOuterSize :: ArrayShape (ShapeBase d) => - TypeBase (ShapeBase d) u -> d -> TypeBase (ShapeBase d) u -setOuterSize = setDimSize 0 - --- | Replace the size of the given dimension of an array. If the --- given type is not an array, it is returned unchanged. -setDimSize :: ArrayShape (ShapeBase d) => - Int -> TypeBase (ShapeBase d) u -> d -> TypeBase (ShapeBase d) u -setDimSize i t e = t `setArrayShape` setDim i (arrayShape t) e - --- | Replace the outermost dimension of an array shape. -setOuterDim :: ShapeBase d -> d -> ShapeBase d -setOuterDim = setDim 0 - --- | Replace the specified dimension of an array shape. -setDim :: Int -> ShapeBase d -> d -> ShapeBase d -setDim i (Shape ds) e = Shape $ take i ds ++ e : drop (i+1) ds - --- | @peelArray n t@ returns the type resulting from peeling the first --- @n@ array dimensions from @t@. Returns @Nothing@ if @t@ has less --- than @n@ dimensions. -peelArray :: ArrayShape shape => - Int -> TypeBase shape u -> Maybe (TypeBase shape u) -peelArray 0 t = Just t -peelArray n (Array et shape u) - | shapeRank shape == n = Just $ Prim et - | shapeRank shape > n = Just $ Array et (stripDims n shape) u -peelArray _ _ = Nothing - --- | @stripArray n t@ removes the @n@ outermost layers of the array. --- Essentially, it is the type of indexing an array of type @t@ with --- @n@ indexes. -stripArray :: ArrayShape shape => Int -> TypeBase shape u -> TypeBase shape u -stripArray n (Array et shape u) - | n < shapeRank shape = Array et (stripDims n shape) u - | otherwise = Prim et -stripArray _ t = t - --- | Return the size of the given dimension. If the dimension does --- not exist, the zero constant is returned. -shapeSize :: Int -> Shape -> SubExp -shapeSize i shape = case drop i $ shapeDims shape of - e : _ -> e - [] -> constant (0 :: Int32) - --- | Return the dimensions of a type - for non-arrays, this is the --- empty list. -arrayDims :: TypeBase Shape u -> [SubExp] -arrayDims = shapeDims . arrayShape - --- | Return the existential dimensions of a type - for non-arrays, --- this is the empty list. -arrayExtDims :: TypeBase ExtShape u -> [ExtSize] -arrayExtDims = shapeDims . arrayShape - --- | Return the size of the given dimension. If the dimension does --- not exist, the zero constant is returned. -arraySize :: Int -> TypeBase Shape u -> SubExp -arraySize i = shapeSize i . arrayShape - --- | Return the size of the given dimension in the first element of --- the given type list. If the dimension does not exist, or no types --- are given, the zero constant is returned. -arraysSize :: Int -> [TypeBase Shape u] -> SubExp -arraysSize _ [] = constant (0 :: Int32) -arraysSize i (t:_) = arraySize i t - --- | Return the immediate row-type of an array. For @[[int]]@, this --- would be @[int]@. -rowType :: ArrayShape shape => TypeBase shape u -> TypeBase shape u -rowType = stripArray 1 - --- | A type is a primitive type if it is not an array or memory block. -primType :: TypeBase shape u -> Bool -primType Array{} = False -primType Mem{} = False -primType _ = True - --- | Returns the bottommost type of an array. For @[[int]]@, this --- would be @int@. If the given type is not an array, it is returned. -elemType :: TypeBase shape u -> PrimType -elemType (Array t _ _) = t -elemType (Prim t) = t -elemType Mem{} = error "elemType Mem" - --- | Swap the two outer dimensions of the type. -transposeType :: Type -> Type -transposeType = rearrangeType [1,0] - --- | Rearrange the dimensions of the type. If the length of the --- permutation does not match the rank of the type, the permutation --- will be extended with identity. -rearrangeType :: [Int] -> Type -> Type -rearrangeType perm t = - t `setArrayShape` Shape (rearrangeShape perm' $ arrayDims t) - where perm' = perm ++ [length perm .. arrayRank t - 1] - --- | @diet t@ returns a description of how a function parameter of --- type @t@ might consume its argument. -diet :: TypeBase shape Uniqueness -> Diet -diet (Prim _) = ObservePrim -diet (Array _ _ Unique) = Consume -diet (Array _ _ Nonunique) = Observe -diet Mem{} = Observe - --- | @x \`subtypeOf\` y@ is true if @x@ is a subtype of @y@ (or equal to --- @y@), meaning @x@ is valid whenever @y@ is. -subtypeOf :: (Ord u, ArrayShape shape) => - TypeBase shape u - -> TypeBase shape u - -> Bool -subtypeOf (Array t1 shape1 u1) (Array t2 shape2 u2) = - u2 <= u1 && - t1 == t2 && - shape1 `subShapeOf` shape2 -subtypeOf (Prim t1) (Prim t2) = t1 == t2 -subtypeOf (Mem space1) (Mem space2) = space1 == space2 -subtypeOf _ _ = False - --- | @xs \`subtypesOf\` ys@ is true if @xs@ is the same size as @ys@, --- and each element in @xs@ is a subtype of the corresponding element --- in @ys@.. -subtypesOf :: (Ord u, ArrayShape shape) => - [TypeBase shape u] - -> [TypeBase shape u] - -> Bool -subtypesOf xs ys = length xs == length ys && - and (zipWith subtypeOf xs ys) - -toDecl :: TypeBase shape NoUniqueness - -> Uniqueness - -> TypeBase shape Uniqueness -toDecl (Prim bt) _ = Prim bt -toDecl (Array et shape _) u = Array et shape u -toDecl (Mem space) _ = Mem space - -fromDecl :: TypeBase shape Uniqueness - -> TypeBase shape NoUniqueness -fromDecl (Prim bt) = Prim bt -fromDecl (Array et shape _) = Array et shape NoUniqueness -fromDecl (Mem space) = Mem space - -isExt :: Ext a -> Maybe Int -isExt (Ext i) = Just i -isExt _ = Nothing - --- | Given the existential return type of a function, and the shapes --- of the values returned by the function, return the existential --- shape context. That is, those sizes that are existential in the --- return type. -extractShapeContext :: [TypeBase ExtShape u] -> [[a]] -> [a] -extractShapeContext ts shapes = - evalState (concat <$> zipWithM extract ts shapes) S.empty - where extract t shape = - catMaybes <$> zipWithM extract' (shapeDims $ arrayShape t) shape - extract' (Ext x) v = do - seen <- gets $ S.member x - if seen then return Nothing - else do modify $ S.insert x - return $ Just v - extract' (Free _) _ = return Nothing - --- | The set of identifiers used for the shape context in the given --- 'ExtType's. -shapeContext :: [TypeBase ExtShape u] -> S.Set Int -shapeContext = S.fromList - . concatMap (mapMaybe ext . shapeDims . arrayShape) - where ext (Ext x) = Just x - ext (Free _) = Nothing - --- | If all dimensions of the given 'RetType' are statically known, --- return the corresponding list of 'Type'. -hasStaticShape :: ExtType -> Maybe Type -hasStaticShape (Prim bt) = Just $ Prim bt -hasStaticShape (Mem space) = Just $ Mem space -hasStaticShape (Array bt (Shape shape) u) = - Array bt <$> (Shape <$> mapM isFree shape) <*> pure u - where isFree (Free s) = Just s - isFree (Ext _) = Nothing - --- | Given two lists of 'ExtType's of the same length, return a list --- of 'ExtType's that is a subtype (as per 'isSubtypeOf') of the two --- operands. -generaliseExtTypes :: [TypeBase ExtShape u] - -> [TypeBase ExtShape u] - -> [TypeBase ExtShape u] -generaliseExtTypes rt1 rt2 = - evalState (zipWithM unifyExtShapes rt1 rt2) (0, M.empty) - where unifyExtShapes t1 t2 = - setArrayShape t1 . Shape <$> - zipWithM unifyExtDims - (shapeDims $ arrayShape t1) - (shapeDims $ arrayShape t2) - unifyExtDims (Free se1) (Free se2) - | se1 == se2 = return $ Free se1 -- Arbitrary - | otherwise = do (n,m) <- get - put (n + 1, m) - return $ Ext n - unifyExtDims (Ext x) (Ext y) - | x == y = Ext <$> (maybe (new x) return =<< - gets (M.lookup x . snd)) - unifyExtDims (Ext x) _ = Ext <$> new x - unifyExtDims _ (Ext x) = Ext <$> new x - new x = do (n,m) <- get - put (n + 1, M.insert x n m) - return n - --- | Given a list of 'ExtType's and a list of "forbidden" names, --- modify the dimensions of the 'ExtType's such that they are 'Ext' --- where they were previously 'Free' with a variable in the set of --- forbidden names. -existentialiseExtTypes :: [VName] -> [ExtType] -> [ExtType] -existentialiseExtTypes inaccessible = map makeBoundShapesFree - where makeBoundShapesFree = - modifyArrayShape $ fmap checkDim - checkDim (Free (Var v)) - | Just i <- v `elemIndex` inaccessible = - Ext i - checkDim d = d - --- | In the call @shapeMapping ts1 ts2@, the lists @ts1@ and @ts@ must --- be of equal length and their corresponding elements have the same --- types modulo exact dimensions (but matching array rank is --- important). The result is a mapping from named dimensions of @ts1@ --- to a set of the corresponding dimensions in @ts2@ (because they may --- not fit exactly). --- --- This function is useful when @ts1@ are the value parameters of some --- function and @ts2@ are the value arguments, and we need to figure --- out which shape context to pass. -shapeMapping :: [TypeBase Shape u0] -> [TypeBase Shape u1] -> M.Map VName (S.Set SubExp) -shapeMapping ts = shapeMapping' ts . map arrayDims - --- | Like @shapeMapping@, but works with explicit dimensions. -shapeMapping' :: Ord a => [TypeBase Shape u] -> [[a]] -> M.Map VName (S.Set a) -shapeMapping' = dimMapping arrayDims id match (M.unionWith (<>)) - where match Constant{} _ = M.empty - match (Var v) dim = M.singleton v $ S.singleton dim - --- | Like 'shapeMapping', but produces a mapping for the dimensions context. -shapeExtMapping :: [TypeBase ExtShape u] -> [TypeBase Shape u1] -> M.Map Int SubExp -shapeExtMapping = dimMapping arrayExtDims arrayDims match mappend - where match Free{} _ = mempty - match (Ext i) dim = M.singleton i dim - -dimMapping :: Monoid res => - (t1 -> [dim1]) -> (t2 -> [dim2]) -> (dim1 -> dim2 -> res) - -> (res -> res -> res) - -> [t1] -> [t2] - -> res -dimMapping getDims1 getDims2 f comb ts1 ts2 = - foldl' comb mempty $ concat $ zipWith (zipWith f) (map getDims1 ts1) (map getDims2 ts2) - -int8 :: PrimType -int8 = IntType Int8 - -int16 :: PrimType -int16 = IntType Int16 - -int32 :: PrimType -int32 = IntType Int32 - -int64 :: PrimType -int64 = IntType Int64 - -float32 :: PrimType -float32 = FloatType Float32 - -float64 :: PrimType -float64 = FloatType Float64 - --- | Typeclass for things that contain 'Type's. -class Typed t where - typeOf :: t -> Type - -instance Typed Type where - typeOf = id - -instance Typed DeclType where - typeOf = fromDecl - -instance Typed Ident where - typeOf = identType - -instance Typed attr => Typed (Param attr) where - typeOf = typeOf . paramAttr - -instance Typed attr => Typed (PatElemT attr) where - typeOf = typeOf . patElemAttr - -instance Typed b => Typed (a,b) where - typeOf = typeOf . snd - --- | Typeclass for things that contain 'DeclType's. -class DeclTyped t where - declTypeOf :: t -> DeclType - -instance DeclTyped DeclType where - declTypeOf = id - -instance DeclTyped attr => DeclTyped (Param attr) where - declTypeOf = declTypeOf . paramAttr - --- | Typeclass for things that contain 'ExtType's. -class FixExt t => ExtTyped t where - extTypeOf :: t -> ExtType - -instance ExtTyped ExtType where - extTypeOf = id - --- | Typeclass for things that contain 'DeclExtType's. -class FixExt t => DeclExtTyped t where - declExtTypeOf :: t -> DeclExtType - -instance DeclExtTyped DeclExtType where - declExtTypeOf = id - --- | Typeclass for things whose type can be changed. -class Typed a => SetType a where - setType :: a -> Type -> a - -instance SetType Type where - setType _ t = t - -instance SetType b => SetType (a, b) where - setType (a, b) t = (a, setType b t) - -instance SetType attr => SetType (PatElemT attr) where - setType (PatElem name attr) t = - PatElem name $ setType attr t - --- | Something with an existential context that can be (partially) --- fixed. -class FixExt t where - -- | Fix the given existentional variable to the indicated free - -- value. - fixExt :: Int -> SubExp -> t -> t - -instance (FixExt shape, ArrayShape shape) => FixExt (TypeBase shape u) where - fixExt i se = modifyArrayShape $ fixExt i se - -instance FixExt d => FixExt (ShapeBase d) where - fixExt i se = fmap $ fixExt i se - -instance FixExt a => FixExt [a] where - fixExt i se = fmap $ fixExt i se - -instance FixExt ExtSize where - fixExt i se (Ext j) | j > i = Ext $ j - 1 - | j == i = Free se - | otherwise = Ext j - fixExt _ _ (Free x) = Free x - -instance FixExt () where - fixExt _ _ () = () diff --git a/src/Futhark/Representation/AST/Pretty.hs b/src/Futhark/Representation/AST/Pretty.hs deleted file mode 100644 --- a/src/Futhark/Representation/AST/Pretty.hs +++ /dev/null @@ -1,287 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} --- | Futhark prettyprinter. This module defines 'Pretty' instances --- for the AST defined in "Futhark.Representation.AST.Syntax", --- but also a number of convenience functions if you don't want to use --- the interface from 'Pretty'. -module Futhark.Representation.AST.Pretty - ( prettyTuple - , pretty - , PrettyAnnot (..) - , PrettyLore (..) - , ppTuple' - , bindingAnnotation - ) - where - -import Data.Maybe - -import Futhark.Util.Pretty -import Futhark.Representation.AST.Attributes.Patterns -import Futhark.Representation.AST.Syntax - --- | Class for values that may have some prettyprinted annotation. -class PrettyAnnot a where - ppAnnot :: a -> Maybe Doc - -instance PrettyAnnot (PatElemT (TypeBase shape u)) where - ppAnnot = const Nothing - -instance PrettyAnnot (Param (TypeBase shape u)) where - ppAnnot = const Nothing - -instance PrettyAnnot () where - ppAnnot = const Nothing - --- | The class of lores whose annotations can be prettyprinted. -class (Annotations lore, - Pretty (RetType lore), - Pretty (BranchType lore), - Pretty (Param (FParamAttr lore)), - Pretty (Param (LParamAttr lore)), - Pretty (PatElemT (LetAttr lore)), - PrettyAnnot (PatElem lore), - PrettyAnnot (FParam lore), - PrettyAnnot (LParam lore), - Pretty (Op lore)) => PrettyLore lore where - ppExpLore :: ExpAttr lore -> Exp lore -> Maybe Doc - ppExpLore _ (If _ _ _ (IfAttr ts _)) = - Just $ stack $ map (text . ("-- "++)) $ lines $ pretty $ - text "Branch returns:" <+> ppTuple' ts - ppExpLore _ _ = Nothing - -commastack :: [Doc] -> Doc -commastack = align . stack . punctuate comma - -instance Pretty VName where - ppr (VName vn i) = ppr vn <> text "_" <> text (show i) - -instance Pretty NoUniqueness where - ppr _ = mempty - -instance Pretty Commutativity where - ppr Commutative = text "commutative" - ppr Noncommutative = text "noncommutative" - -instance Pretty Shape where - ppr = brackets . commasep . map ppr . shapeDims - -instance Pretty a => Pretty (Ext a) where - ppr (Free e) = ppr e - ppr (Ext x) = text "?" <> text (show x) - -instance Pretty ExtShape where - ppr = brackets . commasep . map ppr . shapeDims - -instance Pretty Space where - ppr DefaultSpace = mempty - ppr (Space s) = text "@" <> text s - ppr (ScalarSpace d t) = text "@" <> mconcat (map (brackets . ppr) d) <> ppr t - -instance Pretty u => Pretty (TypeBase Shape u) where - ppr (Prim et) = ppr et - ppr (Array et (Shape ds) u) = - ppr u <> mconcat (map (brackets . ppr) ds) <> ppr et - ppr (Mem s) = text "mem" <> ppr s - -instance Pretty u => Pretty (TypeBase ExtShape u) where - ppr (Prim et) = ppr et - ppr (Array et (Shape ds) u) = - ppr u <> mconcat (map (brackets . ppr) ds) <> ppr et - ppr (Mem s) = text "mem" <> ppr s - -instance Pretty u => Pretty (TypeBase Rank u) where - ppr (Prim et) = ppr et - ppr (Array et (Rank n) u) = - ppr u <> mconcat (replicate n $ brackets mempty) <> ppr et - ppr (Mem s) = text "mem" <> ppr s - -instance Pretty Ident where - ppr ident = ppr (identType ident) <+> ppr (identName ident) - -instance Pretty SubExp where - ppr (Var v) = ppr v - ppr (Constant v) = ppr v - -instance Pretty Certificates where - ppr (Certificates []) = empty - ppr (Certificates cs) = text "<" <> commasep (map ppr cs) <> text ">" - -instance PrettyLore lore => Pretty (Stms lore) where - ppr = stack . map ppr . stmsToList - -instance PrettyLore lore => Pretty (Body lore) where - ppr (Body _ stms res) - | null stms = braces (commasep $ map ppr res) - | otherwise = stack (map ppr $ stmsToList stms) - text "in" <+> braces (commasep $ map ppr res) - -bindingAnnotation :: PrettyLore lore => Stm lore -> Doc -> Doc -bindingAnnotation bnd = - case mapMaybe ppAnnot $ patternElements $ stmPattern bnd of - [] -> id - annots -> (stack annots ) - -instance Pretty (PatElemT attr) => Pretty (PatternT attr) where - ppr pat = ppPattern (patternContextElements pat) (patternValueElements pat) - -instance Pretty (PatElemT b) => Pretty (PatElemT (a,b)) where - ppr = ppr . fmap snd - -instance Pretty (PatElemT Type) where - ppr (PatElem name t) = ppr t <+> ppr name - -instance Pretty (Param b) => Pretty (Param (a,b)) where - ppr = ppr . fmap snd - -instance Pretty (Param DeclType) where - ppr (Param name t) = - ppr t <+> - ppr name - -instance Pretty (Param Type) where - ppr (Param name t) = - ppr t <+> - ppr name - -instance PrettyLore lore => Pretty (Stm lore) where - ppr bnd@(Let pat (StmAux cs attr) e) = - bindingAnnotation bnd $ align $ hang 2 $ - text "let" <+> align (ppr pat) <+> - case (linebreak, ppExpLore attr e) of - (True, Nothing) -> equals e' - (_, Just ann) -> equals (ann e') - (False, Nothing) -> equals <+/> e' - where e' | linebreak = ppr cs ppr e - | otherwise = ppr cs <> ppr e - linebreak = case e of - DoLoop{} -> True - Op{} -> True - If{} -> True - Apply{} -> True - BasicOp ArrayLit{} -> False - BasicOp Assert{} -> True - _ -> cs /= mempty - -instance Pretty BasicOp where - ppr (SubExp se) = ppr se - ppr (Opaque e) = text "opaque" <> apply [ppr e] - ppr (ArrayLit [] rt) = - text "empty" <> parens (ppr rt) - ppr (ArrayLit es rt) = - case rt of - Array {} -> brackets $ commastack $ map ppr es - _ -> brackets $ commasep $ map ppr es - ppr (BinOp bop x y) = ppr bop <> parens (ppr x <> comma <+> ppr y) - ppr (CmpOp op x y) = ppr op <> parens (ppr x <> comma <+> ppr y) - ppr (ConvOp conv x) = - text (convOpFun conv) <+> ppr fromtype <+> ppr x <+> text "to" <+> ppr totype - where (fromtype, totype) = convOpType conv - ppr (UnOp op e) = ppr op <+> pprPrec 9 e - ppr (Index v idxs) = - ppr v <> brackets (commasep (map ppr idxs)) - ppr (Update src idxs se) = - ppr src <+> text "with" <+> brackets (commasep (map ppr idxs)) <+> - text "<-" <+> ppr se - ppr (Iota e x s et) = text "iota" <> et' <> apply [ppr e, ppr x, ppr s] - where et' = text $ show $ primBitSize $ IntType et - ppr (Replicate ne ve) = - text "replicate" <> apply [ppr ne, align (ppr ve)] - ppr (Repeat shapes innershape v) = - text "repeat" <> apply [apply $ map ppr $ shapes ++ [innershape], ppr v] - ppr (Scratch t shape) = - text "scratch" <> apply (ppr t : map ppr shape) - ppr (Reshape shape e) = - text "reshape" <> apply [apply (map ppr shape), ppr e] - ppr (Rearrange perm e) = - text "rearrange" <> apply [apply (map ppr perm), ppr e] - ppr (Rotate es e) = - text "rotate" <> apply [apply (map ppr es), ppr e] - ppr (Concat i x ys _) = - text "concat" <> text "@" <> ppr i <> apply (ppr x : map ppr ys) - ppr (Copy e) = text "copy" <> parens (ppr e) - ppr (Manifest perm e) = text "manifest" <> apply [apply (map ppr perm), ppr e] - ppr (Assert e msg (loc, _)) = - text "assert" <> apply [ppr e, ppr msg, text $ show $ locStr loc] - -instance Pretty a => Pretty (ErrorMsg a) where - ppr (ErrorMsg parts) = commasep $ map p parts - where p (ErrorString s) = text $ show s - p (ErrorInt32 x) = ppr x - -instance PrettyLore lore => Pretty (Exp lore) where - ppr (If c t f (IfAttr _ ifsort)) = - text "if" <+> info' <+> ppr c - text "then" <+> maybeNest t <+> - text "else" <+> maybeNest f - where info' = case ifsort of IfNormal -> mempty - IfFallback -> text "" - IfEquiv -> text "" - maybeNest b | null $ bodyStms b = ppr b - | otherwise = nestedBlock "{" "}" $ ppr b - ppr (BasicOp op) = ppr op - ppr (Apply fname args _ (safety, _, _)) = - text (nameToString fname) <> safety' <> apply (map (align . pprArg) args) - where pprArg (arg, Consume) = text "*" <> ppr arg - pprArg (arg, _) = ppr arg - safety' = case safety of Unsafe -> text "" - Safe -> mempty - ppr (Op op) = ppr op - ppr (DoLoop ctx val form loopbody) = - annot (mapMaybe ppAnnot (ctxparams++valparams)) $ - text "loop" <+> ppPattern ctxparams valparams <+> - equals <+> ppTuple' (ctxinit++valinit) - (case form of - ForLoop i it bound [] -> - text "for" <+> align (ppr i <> text ":" <> ppr it <+> - text "<" <+> align (ppr bound)) - ForLoop i it bound loop_vars -> - annot (mapMaybe (ppAnnot . fst) loop_vars) $ - text "for" <+> align (ppr i <> text ":" <> ppr it <+> - text "<" <+> align (ppr bound) - stack (map pprLoopVar loop_vars)) - WhileLoop cond -> - text "while" <+> ppr cond - ) <+> text "do" <+> nestedBlock "{" "}" (ppr loopbody) - where (ctxparams, ctxinit) = unzip ctx - (valparams, valinit) = unzip val - pprLoopVar (p,a) = ppr p <+> text "in" <+> ppr a - -instance PrettyLore lore => Pretty (Lambda lore) where - ppr (Lambda [] _ []) = text "nilFn" - ppr (Lambda params body rettype) = - annot (mapMaybe ppAnnot params) $ - text "fn" <+> ppTuple' rettype <+/> - align (parens (commasep (map ppr params))) <+> - text "=>" indent 2 (ppr body) - -instance PrettyLore lore => Pretty (FunDef lore) where - ppr (FunDef entry name rettype fparams body) = - annot (mapMaybe ppAnnot fparams) $ - text fun <+> ppTuple' rettype <+/> - text (nameToString name) <+> - apply (map ppr fparams) <+> - equals <+> nestedBlock "{" "}" (ppr body) - where fun | isJust entry = "entry" - | otherwise = "fun" - -instance PrettyLore lore => Pretty (Prog lore) where - ppr (Prog consts funs) = - stack $ punctuate line $ ppr consts : map ppr funs - -instance Pretty d => Pretty (DimChange d) where - ppr (DimCoercion se) = text "~" <> ppr se - ppr (DimNew se) = ppr se - -instance Pretty d => Pretty (DimIndex d) where - ppr (DimFix i) = ppr i - ppr (DimSlice i n s) = ppr i <> text ":+" <> ppr n <> text "*" <> ppr s - -ppPattern :: (Pretty a, Pretty b) => [a] -> [b] -> Doc -ppPattern [] bs = braces $ commasep $ map ppr bs -ppPattern as bs = braces $ commasep (map ppr as) <> semi commasep (map ppr bs) - -ppTuple' :: Pretty a => [a] -> Doc -ppTuple' ets = braces $ commasep $ map ppr ets diff --git a/src/Futhark/Representation/AST/RetType.hs b/src/Futhark/Representation/AST/RetType.hs deleted file mode 100644 --- a/src/Futhark/Representation/AST/RetType.hs +++ /dev/null @@ -1,92 +0,0 @@ -{-# LANGUAGE FlexibleInstances, TypeFamilies #-} --- | This module exports a type class covering representations of --- function return types. -module Futhark.Representation.AST.RetType - ( - IsBodyType (..) - , bodyTypeValues - , IsRetType (..) - , retTypeValues - , expectedTypes - ) - where - -import qualified Data.Map.Strict as M - -import Futhark.Representation.AST.Syntax.Core -import Futhark.Representation.AST.Attributes.Types - --- | A type representing the return type of a body. It should contain --- at least the information contained in a list of 'ExtType's, but may --- have more, notably an existential context. -class (Show rt, Eq rt, Ord rt, ExtTyped rt) => IsBodyType rt where - -- | Construct a body type from a primitive type. - primBodyType :: PrimType -> rt - -bodyTypeValues :: IsBodyType rt => [rt] -> [ExtType] -bodyTypeValues = map extTypeOf - -instance IsBodyType ExtType where - primBodyType = Prim - --- | A type representing the return type of a function. In practice, --- a list of these will be used. It should contain at least the --- information contained in an 'ExtType', but may have more, notably --- an existential context. -class (Show rt, Eq rt, Ord rt, DeclExtTyped rt) => IsRetType rt where - -- | Contruct a return type from a primitive type. - primRetType :: PrimType -> rt - - -- | Given a function return type, the parameters of the function, - -- and the arguments for a concrete call, return the instantiated - -- return type for the concrete call, if valid. - applyRetType :: Typed attr => - [rt] - -> [Param attr] - -> [(SubExp, Type)] - -> Maybe [rt] - -retTypeValues :: IsRetType rt => [rt] -> [DeclExtType] -retTypeValues = map declExtTypeOf - --- | Given shape parameter names and value parameter types, produce the --- types of arguments accepted. -expectedTypes :: Typed t => [VName] -> [t] -> [SubExp] -> [Type] -expectedTypes shapes value_ts args = map (correctDims . typeOf) value_ts - where parammap :: M.Map VName SubExp - parammap = M.fromList $ zip shapes args - - correctDims t = - t `setArrayShape` - Shape (map correctDim $ shapeDims $ arrayShape t) - - correctDim (Constant v) = Constant v - correctDim (Var v) - | Just se <- M.lookup v parammap = se - | otherwise = Var v - -instance IsRetType DeclExtType where - primRetType = Prim - - applyRetType extret params args = - if length args == length params && - and (zipWith subtypeOf argtypes $ - expectedTypes (map paramName params) params $ map fst args) - then Just $ map correctExtDims extret - else Nothing - where argtypes = map snd args - - parammap :: M.Map VName SubExp - parammap = M.fromList $ zip (map paramName params) (map fst args) - - correctExtDims t = - t `setArrayShape` - Shape (map correctExtDim $ shapeDims $ arrayShape t) - - correctExtDim (Ext i) = Ext i - correctExtDim (Free d) = Free $ correctDim d - - correctDim (Constant v) = Constant v - correctDim (Var v) - | Just se <- M.lookup v parammap = se - | otherwise = Var v diff --git a/src/Futhark/Representation/AST/Syntax.hs b/src/Futhark/Representation/AST/Syntax.hs deleted file mode 100644 --- a/src/Futhark/Representation/AST/Syntax.hs +++ /dev/null @@ -1,392 +0,0 @@ -{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances, StandaloneDeriving #-} -{-# LANGUAGE Strict #-} -{-# LANGUAGE StrictData #-} --- | Futhark core language skeleton. Concrete representations further --- extend this skeleton by defining a "lore", which specifies concrete --- annotations ("Futhark.Representation.AST.Annotations") and --- semantics. -module Futhark.Representation.AST.Syntax - ( - module Language.Futhark.Core - , module Futhark.Representation.AST.Annotations - , module Futhark.Representation.AST.Syntax.Core - - -- * Types - , Uniqueness(..) - , NoUniqueness(..) - , Rank(..) - , ArrayShape(..) - , Space (..) - , TypeBase(..) - , Diet(..) - - -- * Abstract syntax tree - , Ident (..) - , SubExp(..) - , PatElem - , PatElemT (..) - , PatternT (..) - , Pattern - , StmAux(..) - , Stm(..) - , Stms - , Result - , BodyT(..) - , Body - , BasicOp (..) - , UnOp (..) - , BinOp (..) - , CmpOp (..) - , ConvOp (..) - , DimChange (..) - , ShapeChange - , ExpT(..) - , Exp - , LoopForm (..) - , IfAttr (..) - , IfSort (..) - , Safety (..) - , LambdaT(..) - , Lambda - - -- * Definitions - , Param (..) - , FParam - , LParam - , FunDef (..) - , EntryPoint - , EntryPointType(..) - , Prog(..) - - -- * Utils - , oneStm - , stmsFromList - , stmsToList - , stmsHead - ) - where - -import Data.Foldable -import Data.Loc -import qualified Data.Sequence as Seq - -import Language.Futhark.Core -import Futhark.Representation.AST.Annotations -import Futhark.Representation.AST.Syntax.Core - --- | A type alias for namespace control. -type PatElem lore = PatElemT (LetAttr lore) - --- | A pattern is conceptually just a list of names and their types. -data PatternT attr = - Pattern { patternContextElements :: [PatElemT attr] - -- ^ existential context (sizes and memory blocks) - , patternValueElements :: [PatElemT attr] - -- ^ "real" values - } - deriving (Ord, Show, Eq) - -instance Functor PatternT where - fmap f (Pattern ctx val) = Pattern (map (fmap f) ctx) (map (fmap f) val) - -instance Semigroup (PatternT attr) where - Pattern cs1 vs1 <> Pattern cs2 vs2 = Pattern (cs1++cs2) (vs1++vs2) - -instance Monoid (PatternT attr) where - mempty = Pattern [] [] - --- | A type alias for namespace control. -type Pattern lore = PatternT (LetAttr lore) - --- | Auxilliary Information associated with a statement. -data StmAux attr = StmAux { stmAuxCerts :: !Certificates - , stmAuxAttr :: attr - } - deriving (Ord, Show, Eq) - --- | A local variable binding. -data Stm lore = Let { stmPattern :: Pattern lore - , stmAux :: StmAux (ExpAttr lore) - , stmExp :: Exp lore - } - -deriving instance Annotations lore => Ord (Stm lore) -deriving instance Annotations lore => Show (Stm lore) -deriving instance Annotations lore => Eq (Stm lore) - --- | A sequence of statements. -type Stms lore = Seq.Seq (Stm lore) - -oneStm :: Stm lore -> Stms lore -oneStm = Seq.singleton - -stmsFromList :: [Stm lore] -> Stms lore -stmsFromList = Seq.fromList - -stmsToList :: Stms lore -> [Stm lore] -stmsToList = toList - -stmsHead :: Stms lore -> Maybe (Stm lore, Stms lore) -stmsHead stms = case Seq.viewl stms of stm Seq.:< stms' -> Just (stm, stms') - Seq.EmptyL -> Nothing - --- | The result of a body is a sequence of subexpressions. -type Result = [SubExp] - --- | A body consists of a number of bindings, terminating in a result --- (essentially a tuple literal). -data BodyT lore = Body { bodyAttr :: BodyAttr lore - , bodyStms :: Stms lore - , bodyResult :: Result - } - -deriving instance Annotations lore => Ord (BodyT lore) -deriving instance Annotations lore => Show (BodyT lore) -deriving instance Annotations lore => Eq (BodyT lore) - --- | Type alias for namespace reasons. -type Body = BodyT - --- | The new dimension in a 'Reshape'-like operation. This allows us to --- disambiguate "real" reshapes, that change the actual shape of the --- array, from type coercions that are just present to make the types --- work out. The two constructors are considered equal for purposes of 'Eq'. -data DimChange d = DimCoercion d - -- ^ The new dimension is guaranteed to be numerically - -- equal to the old one. - | DimNew d - -- ^ The new dimension is not necessarily numerically - -- equal to the old one. - deriving (Ord, Show) - -instance Eq d => Eq (DimChange d) where - DimCoercion x == DimNew y = x == y - DimCoercion x == DimCoercion y = x == y - DimNew x == DimCoercion y = x == y - DimNew x == DimNew y = x == y - -instance Functor DimChange where - fmap f (DimCoercion d) = DimCoercion $ f d - fmap f (DimNew d) = DimNew $ f d - -instance Foldable DimChange where - foldMap f (DimCoercion d) = f d - foldMap f (DimNew d) = f d - -instance Traversable DimChange where - traverse f (DimCoercion d) = DimCoercion <$> f d - traverse f (DimNew d) = DimNew <$> f d - --- | A list of 'DimChange's, indicating the new dimensions of an array. -type ShapeChange d = [DimChange d] - --- | A primitive operation that returns something of known size and --- does not itself contain any bindings. -data BasicOp - = SubExp SubExp - -- ^ A variable or constant. - - | Opaque SubExp - -- ^ Semantically and operationally just identity, but is - -- invisible/impenetrable to optimisations (hopefully). This is - -- just a hack to avoid optimisation (so, to work around compiler - -- limitations). - - | ArrayLit [SubExp] Type - -- ^ Array literals, e.g., @[ [1+x, 3], [2, 1+4] ]@. - -- Second arg is the element type of the rows of the array. - -- Scalar operations - - | UnOp UnOp SubExp - -- ^ Unary operation. - - | BinOp BinOp SubExp SubExp - -- ^ Binary operation. - - | CmpOp CmpOp SubExp SubExp - -- ^ Comparison - result type is always boolean. - - | ConvOp ConvOp SubExp - -- ^ Conversion "casting". - - | Assert SubExp (ErrorMsg SubExp) (SrcLoc, [SrcLoc]) - -- ^ Turn a boolean into a certificate, halting the program with the - -- given error message if the boolean is false. - - -- Primitive array operations - - | Index VName (Slice SubExp) - -- ^ The certificates for bounds-checking are part of the 'Stm'. - - | Update VName (Slice SubExp) SubExp - -- ^ An in-place update of the given array at the given position. - -- Consumes the array. - - | Concat Int VName [VName] SubExp - -- ^ @concat@0([1],[2, 3, 4]) = [1, 2, 3, 4]@. - - | Copy VName - -- ^ Copy the given array. The result will not alias anything. - - | Manifest [Int] VName - -- ^ Manifest an array with dimensions represented in the given - -- order. The result will not alias anything. - - -- Array construction. - | Iota SubExp SubExp SubExp IntType - -- ^ @iota(n, x, s) = [x,x+s,..,x+(n-1)*s]@. - -- - -- The 'IntType' indicates the type of the array returned and the - -- offset/stride arguments, but not the length argument. - - | Replicate Shape SubExp - -- ^ @replicate([3][2],1) = [[1,1], [1,1], [1,1]]@ - - | Repeat [Shape] Shape VName - -- ^ Repeat each dimension of the input array some number of times, - -- given by the corresponding shape. For an array of rank @k@, the - -- list must contain @k@ shapes. A shape may be empty (in which - -- case the dimension is not repeated, but it is still present). - -- The last shape indicates the amount of extra innermost - -- dimensions. All other extra dimensions are added *before* the original dimension. - - | Scratch PrimType [SubExp] - -- ^ Create array of given type and shape, with undefined elements. - - -- Array index space transformation. - | Reshape (ShapeChange SubExp) VName - -- ^ 1st arg is the new shape, 2nd arg is the input array *) - - | Rearrange [Int] VName - -- ^ Permute the dimensions of the input array. The list - -- of integers is a list of dimensions (0-indexed), which - -- must be a permutation of @[0,n-1]@, where @n@ is the - -- number of dimensions in the input array. - - | Rotate [SubExp] VName - -- ^ Rotate the dimensions of the input array. The list of - -- subexpressions specify how much each dimension is rotated. The - -- length of this list must be equal to the rank of the array. - deriving (Eq, Ord, Show) - --- | The root Futhark expression type. The 'Op' constructor contains --- a lore-specific operation. Do-loops, branches and function calls --- are special. Everything else is a simple 'BasicOp'. -data ExpT lore - = BasicOp BasicOp - -- ^ A simple (non-recursive) operation. - - | Apply Name [(SubExp, Diet)] [RetType lore] (Safety, SrcLoc, [SrcLoc]) - - | If SubExp (BodyT lore) (BodyT lore) (IfAttr (BranchType lore)) - - | DoLoop [(FParam lore, SubExp)] [(FParam lore, SubExp)] (LoopForm lore) (BodyT lore) - -- ^ @loop {a} = {v} (for i < n|while b) do b@. The merge - -- parameters are divided into context and value part. - - | Op (Op lore) - -deriving instance Annotations lore => Eq (ExpT lore) -deriving instance Annotations lore => Show (ExpT lore) -deriving instance Annotations lore => Ord (ExpT lore) - --- | Whether something is safe or unsafe (mostly function calls, and --- in the context of whether operations are dynamically checked). --- When we inline an 'Unsafe' function, we remove all safety checks in --- its body. The 'Ord' instance picks 'Unsafe' as being less than --- 'Safe'. -data Safety = Unsafe | Safe deriving (Eq, Ord, Show) - --- | For-loop or while-loop? -data LoopForm lore = ForLoop VName IntType SubExp [(LParam lore,VName)] - | WhileLoop VName - -deriving instance Annotations lore => Eq (LoopForm lore) -deriving instance Annotations lore => Show (LoopForm lore) -deriving instance Annotations lore => Ord (LoopForm lore) - --- | Data associated with a branch. -data IfAttr rt = IfAttr { ifReturns :: [rt] - , ifSort :: IfSort - } - deriving (Eq, Show, Ord) - -data IfSort = IfNormal -- ^ An ordinary branch. - | IfFallback -- ^ A branch where the "true" case is what - -- we are actually interested in, and the - -- "false" case is only present as a fallback - -- for when the true case cannot be safely - -- evaluated. the compiler is permitted to - -- optimise away the branch if the true case - -- contains only safe statements. - | IfEquiv -- ^ Both of these branches are semantically - -- equivalent, and it is fine to eliminate one - -- if it turns out to have problems - -- (e.g. contain things we cannot generate code - -- for). - deriving (Eq, Show, Ord) - --- | A type alias for namespace control. -type Exp = ExpT - --- | Anonymous function for use in a SOAC. -data LambdaT lore = Lambda { lambdaParams :: [LParam lore] - , lambdaBody :: BodyT lore - , lambdaReturnType :: [Type] - } - -deriving instance Annotations lore => Eq (LambdaT lore) -deriving instance Annotations lore => Show (LambdaT lore) -deriving instance Annotations lore => Ord (LambdaT lore) - --- | Type alias for namespacing reasons. -type Lambda = LambdaT - -type FParam lore = Param (FParamAttr lore) - -type LParam lore = Param (LParamAttr lore) - --- | Function Declarations -data FunDef lore = FunDef { funDefEntryPoint :: Maybe EntryPoint - -- ^ Contains a value if this function is - -- an entry point. - , funDefName :: Name - , funDefRetType :: [RetType lore] - , funDefParams :: [FParam lore] - , funDefBody :: BodyT lore - } - -deriving instance Annotations lore => Eq (FunDef lore) -deriving instance Annotations lore => Show (FunDef lore) -deriving instance Annotations lore => Ord (FunDef lore) - --- | Information about the parameters and return value of an entry --- point. The first element is for parameters, the second for return --- value. -type EntryPoint = ([EntryPointType], [EntryPointType]) - --- | Every entry point argument and return value has an annotation --- indicating how it maps to the original source program type. -data EntryPointType = TypeUnsigned - -- ^ Is an unsigned integer or array of unsigned - -- integers. - | TypeOpaque String Int - -- ^ A black box type comprising this many core - -- values. The string is a human-readable - -- description with no other semantics. - | TypeDirect - -- ^ Maps directly. - deriving (Eq, Show, Ord) - --- | An entire Futhark program. -data Prog lore = Prog - { progConsts :: Stms lore - -- ^ Top-level constants that are computed at program startup, and - -- which are in scope inside all functions. - - , progFuns :: [FunDef lore] - -- ^ The functions comprising the program. All funtions are also - -- available in scope in the definitions of the constants, so be - -- careful not to introduce circular dependencies (not currently - -- checked). - } deriving (Eq, Ord, Show) diff --git a/src/Futhark/Representation/AST/Syntax/Core.hs b/src/Futhark/Representation/AST/Syntax/Core.hs deleted file mode 100644 --- a/src/Futhark/Representation/AST/Syntax/Core.hs +++ /dev/null @@ -1,358 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE Strict #-} -{-# LANGUAGE StrictData #-} --- | The most primitive ("core") aspects of the AST. Split out of --- "Futhark.Representation.AST.Syntax" in order for --- "Futhark.Representation.AST.Annotations" to use these definitions. This --- module is re-exported from "Futhark.Representation.AST.Syntax" and --- there should be no reason to include it explicitly. -module Futhark.Representation.AST.Syntax.Core - ( - module Language.Futhark.Core - , module Futhark.Representation.Primitive - - -- * Types - , Uniqueness(..) - , NoUniqueness(..) - , ShapeBase(..) - , Shape - , Ext(..) - , ExtSize - , ExtShape - , Rank(..) - , ArrayShape(..) - , Space (..) - , SpaceId - , TypeBase(..) - , Type - , ExtType - , DeclType - , DeclExtType - , Diet(..) - , ErrorMsg (..) - , ErrorMsgPart (..) - , errorMsgArgTypes - - -- * Values - , PrimValue(..) - - -- * Abstract syntax tree - , Ident (..) - , Certificates(..) - , SubExp(..) - , Param (..) - , DimIndex (..) - , Slice - , dimFix - , sliceIndices - , sliceDims - , unitSlice - , fixSlice - , PatElemT (..) - ) where - -import Control.Monad.State -import Data.Maybe -import Data.String -import qualified Data.Map.Strict as M -import Data.Traversable - -import Language.Futhark.Core -import Futhark.Representation.Primitive - --- | The size of an array type as a list of its dimension sizes, with --- the type of sizes being parametric. -newtype ShapeBase d = Shape { shapeDims :: [d] } - deriving (Eq, Ord, Show) - --- | The size of an array as a list of subexpressions. If a variable, --- that variable must be in scope where this array is used. -type Shape = ShapeBase SubExp - --- | Something that may be existential. -data Ext a = Ext Int - | Free a - deriving (Eq, Ord, Show) - --- | The size of this dimension. -type ExtSize = Ext SubExp - --- | Like 'Shape' but some of its elements may be bound in a local --- environment instead. These are denoted with integral indices. -type ExtShape = ShapeBase ExtSize - --- | The size of an array type as merely the number of dimensions, --- with no further information. -newtype Rank = Rank Int - deriving (Show, Eq, Ord) - --- | A class encompassing types containing array shape information. -class (Monoid a, Eq a, Ord a) => ArrayShape a where - -- | Return the rank of an array with the given size. - shapeRank :: a -> Int - -- | @stripDims n shape@ strips the outer @n@ dimensions from - -- @shape@. - stripDims :: Int -> a -> a - -- | Check whether one shape if a subset of another shape. - subShapeOf :: a -> a -> Bool - -instance Semigroup (ShapeBase d) where - Shape l1 <> Shape l2 = Shape $ l1 `mappend` l2 - -instance Monoid (ShapeBase d) where - mempty = Shape mempty - -instance Functor ShapeBase where - fmap f = Shape . map f . shapeDims - -instance ArrayShape (ShapeBase SubExp) where - shapeRank (Shape l) = length l - stripDims n (Shape dims) = Shape $ drop n dims - subShapeOf = (==) - -instance ArrayShape (ShapeBase ExtSize) where - shapeRank (Shape l) = length l - stripDims n (Shape dims) = Shape $ drop n dims - subShapeOf (Shape ds1) (Shape ds2) = - -- Must agree on Free dimensions, and ds1 may not be existential - -- where ds2 is Free. Existentials must also be congruent. - length ds1 == length ds2 && - evalState (and <$> zipWithM subDimOf ds1 ds2) M.empty - where subDimOf (Free se1) (Free se2) = return $ se1 == se2 - subDimOf (Ext _) (Free _) = return False - subDimOf (Free _) (Ext _) = return True - subDimOf (Ext x) (Ext y) = do - extmap <- get - case M.lookup y extmap of - Just ywas | ywas == x -> return True - | otherwise -> return False - Nothing -> do put $ M.insert y x extmap - return True - -instance Semigroup Rank where - Rank x <> Rank y = Rank $ x + y - -instance Monoid Rank where - mempty = Rank 0 - -instance ArrayShape Rank where - shapeRank (Rank x) = x - stripDims n (Rank x) = Rank $ x - n - subShapeOf = (==) - --- | The memory space of a block. If 'DefaultSpace', this is the "default" --- space, whatever that is. The exact meaning of the 'SpaceID' --- depends on the backend used. In GPU kernels, for example, this is --- used to distinguish between constant, global and shared memory --- spaces. In GPU-enabled host code, it is used to distinguish --- between host memory ('DefaultSpace') and GPU space. -data Space = DefaultSpace - | Space SpaceId - | ScalarSpace [SubExp] PrimType - -- ^ A special kind of memory that is a statically sized - -- array of some primitive type. Used for private memory - -- on GPUs. - deriving (Show, Eq, Ord) - --- | A string representing a specific non-default memory space. -type SpaceId = String - --- | A fancier name for '()' - encodes no uniqueness information. -data NoUniqueness = NoUniqueness - deriving (Eq, Ord, Show) - --- | An Futhark type is either an array or an element type. When --- comparing types for equality with '==', shapes must match. -data TypeBase shape u = Prim PrimType - | Array PrimType shape u - | Mem Space - deriving (Show, Eq, Ord) - --- | A type with shape information, used for describing the type of --- variables. -type Type = TypeBase Shape NoUniqueness - --- | A type with existentially quantified shapes - used as part of --- function (and function-like) return types. Generally only makes --- sense when used in a list. -type ExtType = TypeBase ExtShape NoUniqueness - --- | A type with shape and uniqueness information, used declaring --- return- and parameters types. -type DeclType = TypeBase Shape Uniqueness - --- | An 'ExtType' with uniqueness information, used for function --- return types. -type DeclExtType = TypeBase ExtShape Uniqueness - --- | Information about which parts of a value/type are consumed. For --- example, we might say that a function taking three arguments of --- types @([int], *[int], [int])@ has diet @[Observe, Consume, --- Observe]@. -data Diet = Consume -- ^ Consumes this value. - | Observe -- ^ Only observes value in this position, does - -- not consume. A result may alias this. - | ObservePrim -- ^ As 'Observe', but the result will not - -- alias, because the parameter does not carry - -- aliases. - deriving (Eq, Ord, Show) - --- | An identifier consists of its name and the type of the value --- bound to the identifier. -data Ident = Ident { identName :: VName - , identType :: Type - } - deriving (Show) - -instance Eq Ident where - x == y = identName x == identName y - -instance Ord Ident where - x `compare` y = identName x `compare` identName y - --- | A list of names used for certificates in some expressions. -newtype Certificates = Certificates { unCertificates :: [VName] } - deriving (Eq, Ord, Show) - -instance Semigroup Certificates where - Certificates x <> Certificates y = Certificates (x <> y) - -instance Monoid Certificates where - mempty = Certificates mempty - --- | A subexpression is either a scalar constant or a variable. One --- important property is that evaluation of a subexpression is --- guaranteed to complete in constant time. -data SubExp = Constant PrimValue - | Var VName - deriving (Show, Eq, Ord) - --- | A function or lambda parameter. -data Param attr = Param - { paramName :: VName - -- ^ Name of the parameter. - , paramAttr :: attr - -- ^ Function parameter attribute. - } - deriving (Ord, Show, Eq) - -instance Foldable Param where - foldMap = foldMapDefault - -instance Functor Param where - fmap = fmapDefault - -instance Traversable Param where - traverse f (Param name attr) = Param name <$> f attr - --- | How to index a single dimension of an array. -data DimIndex d = DimFix - d -- ^ Fix index in this dimension. - | DimSlice d d d - -- ^ @DimSlice start_offset num_elems stride@. - deriving (Eq, Ord, Show) - -instance Functor DimIndex where - fmap f (DimFix i) = DimFix $ f i - fmap f (DimSlice i j s) = DimSlice (f i) (f j) (f s) - -instance Foldable DimIndex where - foldMap f (DimFix d) = f d - foldMap f (DimSlice i j s) = f i <> f j <> f s - -instance Traversable DimIndex where - traverse f (DimFix d) = DimFix <$> f d - traverse f (DimSlice i j s) = DimSlice <$> f i <*> f j <*> f s - --- | A list of 'DimFix's, indicating how an array should be sliced. --- Whenever a function accepts a 'Slice', that slice should be total, --- i.e, cover all dimensions of the array. Deviators should be --- indicated by taking a list of 'DimIndex'es instead. -type Slice d = [DimIndex d] - --- | If the argument is a 'DimFix', return its component. -dimFix :: DimIndex d -> Maybe d -dimFix (DimFix d) = Just d -dimFix _ = Nothing - --- | If the slice is all 'DimFix's, return the components. -sliceIndices :: Slice d -> Maybe [d] -sliceIndices = mapM dimFix - --- | The dimensions of the array produced by this slice. -sliceDims :: Slice d -> [d] -sliceDims = mapMaybe dimSlice - where dimSlice (DimSlice _ d _) = Just d - dimSlice DimFix{} = Nothing - --- | A slice with a stride of one. -unitSlice :: Num d => d -> d -> DimIndex d -unitSlice offset n = DimSlice offset n 1 - --- | Fix the 'DimSlice's of a slice. The number of indexes must equal --- the length of 'sliceDims' for the slice. -fixSlice :: Num d => Slice d -> [d] -> [d] -fixSlice (DimFix j:mis') is' = - j : fixSlice mis' is' -fixSlice (DimSlice orig_k _ orig_s:mis') (i:is') = - (orig_k+i*orig_s) : fixSlice mis' is' -fixSlice _ _ = [] - --- | An element of a pattern - consisting of a name (essentially a --- pair of the name and type) and an addditional parametric attribute. --- This attribute is what is expected to contain the type of the --- resulting variable. -data PatElemT attr = PatElem { patElemName :: VName - -- ^ The name being bound. - , patElemAttr :: attr - -- ^ Pattern element attribute. - } - deriving (Ord, Show, Eq) - -instance Functor PatElemT where - fmap f (PatElem name attr) = PatElem name (f attr) - --- | An error message is a list of error parts, which are concatenated --- to form the final message. -newtype ErrorMsg a = ErrorMsg [ErrorMsgPart a] - deriving (Eq, Ord, Show) - -instance IsString (ErrorMsg a) where - fromString = ErrorMsg . pure . fromString - --- | A part of an error message. -data ErrorMsgPart a = ErrorString String -- ^ A literal string. - | ErrorInt32 a -- ^ A run-time integer value. - deriving (Eq, Ord, Show) - -instance IsString (ErrorMsgPart a) where - fromString = ErrorString - -instance Functor ErrorMsg where - fmap f (ErrorMsg parts) = ErrorMsg $ map (fmap f) parts - -instance Foldable ErrorMsg where - foldMap f (ErrorMsg parts) = foldMap (foldMap f) parts - -instance Traversable ErrorMsg where - traverse f (ErrorMsg parts) = ErrorMsg <$> traverse (traverse f) parts - -instance Functor ErrorMsgPart where - fmap _ (ErrorString s) = ErrorString s - fmap f (ErrorInt32 a) = ErrorInt32 $ f a - -instance Foldable ErrorMsgPart where - foldMap _ ErrorString{} = mempty - foldMap f (ErrorInt32 a) = f a - -instance Traversable ErrorMsgPart where - traverse _ (ErrorString s) = pure $ ErrorString s - traverse f (ErrorInt32 a) = ErrorInt32 <$> f a - --- | How many non-constant parts does the error message have, and what --- is their type? -errorMsgArgTypes :: ErrorMsg a -> [PrimType] -errorMsgArgTypes (ErrorMsg parts) = mapMaybe onPart parts - where onPart ErrorString{} = Nothing - onPart ErrorInt32{} = Just $ IntType Int32 diff --git a/src/Futhark/Representation/AST/Traversals.hs b/src/Futhark/Representation/AST/Traversals.hs deleted file mode 100644 --- a/src/Futhark/Representation/AST/Traversals.hs +++ /dev/null @@ -1,279 +0,0 @@ --- | --- --- Functions for generic traversals across Futhark syntax trees. The --- motivation for this module came from dissatisfaction with rewriting --- the same trivial tree recursions for every module. A possible --- alternative would be to use normal \"Scrap your --- boilerplate\"-techniques, but these are rejected for two reasons: --- --- * They are too slow. --- --- * More importantly, they do not tell you whether you have missed --- some cases. --- --- Instead, this module defines various traversals of the Futhark syntax --- tree. The implementation is rather tedious, but the interface is --- easy to use. --- --- A traversal of the Futhark syntax tree is expressed as a record of --- functions expressing the operations to be performed on the various --- types of nodes. --- --- The "Futhark.Transform.Rename" module is a simple example of how to --- use this facility. -module Futhark.Representation.AST.Traversals - ( - -- * Mapping - Mapper(..) - , identityMapper - , mapExpM - , mapExp - , mapOnType - , mapOnLoopForm - - -- * Walking - , Walker(..) - , identityWalker - , walkExpM - ) - where - -import Control.Monad -import Control.Monad.Identity -import qualified Data.Traversable -import Data.Foldable (traverse_) - -import Futhark.Representation.AST.Syntax -import Futhark.Representation.AST.Attributes.Scope - --- | Express a monad mapping operation on a syntax node. Each element --- of this structure expresses the operation to be performed on a --- given child. -data Mapper flore tlore m = Mapper { - mapOnSubExp :: SubExp -> m SubExp - , mapOnBody :: Scope tlore -> Body flore -> m (Body tlore) - -- ^ Most bodies are enclosed in a scope, which is passed along - -- for convenience. - , mapOnVName :: VName -> m VName - , mapOnRetType :: RetType flore -> m (RetType tlore) - , mapOnBranchType :: BranchType flore -> m (BranchType tlore) - , mapOnFParam :: FParam flore -> m (FParam tlore) - , mapOnLParam :: LParam flore -> m (LParam tlore) - , mapOnOp :: Op flore -> m (Op tlore) - } - --- | A mapper that simply returns the tree verbatim. -identityMapper :: Monad m => Mapper lore lore m -identityMapper = Mapper { - mapOnSubExp = return - , mapOnBody = const return - , mapOnVName = return - , mapOnRetType = return - , mapOnBranchType = return - , mapOnFParam = return - , mapOnLParam = return - , mapOnOp = return - } - --- | Map a monadic action across the immediate children of an --- expression. Importantly, the 'mapOnExp' action is not invoked for --- the expression itself, and the mapping does not descend recursively --- into subexpressions. The mapping is done left-to-right. -mapExpM :: (Applicative m, Monad m) => - Mapper flore tlore m -> Exp flore -> m (Exp tlore) -mapExpM tv (BasicOp (SubExp se)) = - BasicOp <$> (SubExp <$> mapOnSubExp tv se) -mapExpM tv (BasicOp (ArrayLit els rowt)) = - BasicOp <$> (ArrayLit <$> mapM (mapOnSubExp tv) els <*> - mapOnType (mapOnSubExp tv) rowt) -mapExpM tv (BasicOp (BinOp bop x y)) = - BasicOp <$> (BinOp bop <$> mapOnSubExp tv x <*> mapOnSubExp tv y) -mapExpM tv (BasicOp (CmpOp op x y)) = - BasicOp <$> (CmpOp op <$> mapOnSubExp tv x <*> mapOnSubExp tv y) -mapExpM tv (BasicOp (ConvOp conv x)) = - BasicOp <$> (ConvOp conv <$> mapOnSubExp tv x) -mapExpM tv (BasicOp (UnOp op x)) = - BasicOp <$> (UnOp op <$> mapOnSubExp tv x) -mapExpM tv (If c texp fexp (IfAttr ts s)) = - If <$> mapOnSubExp tv c <*> mapOnBody tv mempty texp <*> mapOnBody tv mempty fexp <*> - (IfAttr <$> mapM (mapOnBranchType tv) ts <*> pure s) -mapExpM tv (Apply fname args ret loc) = do - args' <- forM args $ \(arg, d) -> - (,) <$> mapOnSubExp tv arg <*> pure d - Apply fname <$> pure args' <*> mapM (mapOnRetType tv) ret <*> pure loc -mapExpM tv (BasicOp (Index arr slice)) = - BasicOp <$> (Index <$> mapOnVName tv arr <*> - mapM (traverse (mapOnSubExp tv)) slice) -mapExpM tv (BasicOp (Update arr slice se)) = - BasicOp <$> (Update <$> mapOnVName tv arr <*> - mapM (traverse (mapOnSubExp tv)) slice <*> mapOnSubExp tv se) -mapExpM tv (BasicOp (Iota n x s et)) = - BasicOp <$> (Iota <$> mapOnSubExp tv n <*> mapOnSubExp tv x <*> mapOnSubExp tv s <*> pure et) -mapExpM tv (BasicOp (Replicate shape vexp)) = - BasicOp <$> (Replicate <$> mapOnShape tv shape <*> mapOnSubExp tv vexp) -mapExpM tv (BasicOp (Repeat shapes innershape v)) = - BasicOp <$> (Repeat <$> mapM (mapOnShape tv) shapes <*> - mapOnShape tv innershape <*> mapOnVName tv v) -mapExpM tv (BasicOp (Scratch t shape)) = - BasicOp <$> (Scratch t <$> mapM (mapOnSubExp tv) shape) -mapExpM tv (BasicOp (Reshape shape arrexp)) = - BasicOp <$> (Reshape <$> - mapM (Data.Traversable.traverse (mapOnSubExp tv)) shape <*> - mapOnVName tv arrexp) -mapExpM tv (BasicOp (Rearrange perm e)) = - BasicOp <$> (Rearrange <$> pure perm <*> mapOnVName tv e) -mapExpM tv (BasicOp (Rotate es e)) = - BasicOp <$> (Rotate <$> mapM (mapOnSubExp tv) es <*> mapOnVName tv e) -mapExpM tv (BasicOp (Concat i x ys size)) = - BasicOp <$> (Concat <$> pure i <*> - mapOnVName tv x <*> mapM (mapOnVName tv) ys <*> - mapOnSubExp tv size) -mapExpM tv (BasicOp (Copy e)) = - BasicOp <$> (Copy <$> mapOnVName tv e) -mapExpM tv (BasicOp (Manifest perm e)) = - BasicOp <$> (Manifest perm <$> mapOnVName tv e) -mapExpM tv (BasicOp (Assert e msg loc)) = - BasicOp <$> (Assert <$> mapOnSubExp tv e <*> traverse (mapOnSubExp tv) msg <*> pure loc) -mapExpM tv (BasicOp (Opaque e)) = - BasicOp <$> (Opaque <$> mapOnSubExp tv e) -mapExpM tv (DoLoop ctxmerge valmerge form loopbody) = do - ctxparams' <- mapM (mapOnFParam tv) ctxparams - valparams' <- mapM (mapOnFParam tv) valparams - form' <- mapOnLoopForm tv form - let scope = scopeOf form' <> scopeOfFParams (ctxparams'++valparams') - DoLoop <$> - (zip ctxparams' <$> mapM (mapOnSubExp tv) ctxinits) <*> - (zip valparams' <$> mapM (mapOnSubExp tv) valinits) <*> - pure form' <*> mapOnBody tv scope loopbody - where (ctxparams,ctxinits) = unzip ctxmerge - (valparams,valinits) = unzip valmerge -mapExpM tv (Op op) = - Op <$> mapOnOp tv op - -mapOnShape :: Monad m => Mapper flore tlore m -> Shape -> m Shape -mapOnShape tv (Shape ds) = Shape <$> mapM (mapOnSubExp tv) ds - -mapOnLoopForm :: Monad m => - Mapper flore tlore m -> LoopForm flore -> m (LoopForm tlore) -mapOnLoopForm tv (ForLoop i it bound loop_vars) = - ForLoop <$> mapOnVName tv i <*> pure it <*> mapOnSubExp tv bound <*> - (zip <$> mapM (mapOnLParam tv) loop_lparams <*> mapM (mapOnVName tv) loop_arrs) - where (loop_lparams,loop_arrs) = unzip loop_vars -mapOnLoopForm tv (WhileLoop cond) = - WhileLoop <$> mapOnVName tv cond - --- | Like 'mapExp', but in the 'Identity' monad. -mapExp :: Mapper flore tlore Identity -> Exp flore -> Exp tlore -mapExp m = runIdentity . mapExpM m - -mapOnType :: Monad m => - (SubExp -> m SubExp) -> Type -> m Type -mapOnType _ (Prim bt) = return $ Prim bt -mapOnType _ (Mem space) = pure $ Mem space -mapOnType f (Array bt shape u) = - Array bt <$> (Shape <$> mapM f (shapeDims shape)) <*> pure u - --- | Express a monad expression on a syntax node. Each element of --- this structure expresses the action to be performed on a given --- child. -data Walker lore m = Walker { - walkOnSubExp :: SubExp -> m () - , walkOnBody :: Body lore -> m () - , walkOnVName :: VName -> m () - , walkOnRetType :: RetType lore -> m () - , walkOnBranchType :: BranchType lore -> m () - , walkOnFParam :: FParam lore -> m () - , walkOnLParam :: LParam lore -> m () - , walkOnOp :: Op lore -> m () - } - --- | A no-op traversal. -identityWalker :: Monad m => Walker lore m -identityWalker = Walker { - walkOnSubExp = const $ return () - , walkOnBody = const $ return () - , walkOnVName = const $ return () - , walkOnRetType = const $ return () - , walkOnBranchType = const $ return () - , walkOnFParam = const $ return () - , walkOnLParam = const $ return () - , walkOnOp = const $ return () - } - -walkOnShape :: Monad m => Walker lore m -> Shape -> m () -walkOnShape tv (Shape ds) = mapM_ (walkOnSubExp tv) ds - -walkOnType :: Monad m => - (SubExp -> m ()) -> Type -> m () -walkOnType _ Prim{} = return () -walkOnType _ Mem{} = return () -walkOnType f (Array _ shape _) = mapM_ f $ shapeDims shape - -walkOnLoopForm :: Monad m => Walker lore m -> LoopForm lore -> m () -walkOnLoopForm tv (ForLoop i _ bound loop_vars) = - walkOnVName tv i >> walkOnSubExp tv bound >> - mapM_ (walkOnLParam tv) loop_lparams >> mapM_ (walkOnVName tv) loop_arrs - where (loop_lparams,loop_arrs) = unzip loop_vars -walkOnLoopForm tv (WhileLoop cond) = - walkOnVName tv cond - --- | As 'mapExpM', but do not construct a result AST. -walkExpM :: Monad m => Walker lore m -> Exp lore -> m () -walkExpM tv (BasicOp (SubExp se)) = - walkOnSubExp tv se -walkExpM tv (BasicOp (ArrayLit els rowt)) = - mapM_ (walkOnSubExp tv) els >> walkOnType (walkOnSubExp tv) rowt -walkExpM tv (BasicOp (BinOp _ x y)) = - walkOnSubExp tv x >> walkOnSubExp tv y -walkExpM tv (BasicOp (CmpOp _ x y)) = - walkOnSubExp tv x >> walkOnSubExp tv y -walkExpM tv (BasicOp (ConvOp _ x)) = - walkOnSubExp tv x -walkExpM tv (BasicOp (UnOp _ x)) = - walkOnSubExp tv x -walkExpM tv (If c texp fexp (IfAttr ts _)) = - walkOnSubExp tv c >> walkOnBody tv texp >> - walkOnBody tv fexp >> mapM_ (walkOnBranchType tv) ts -walkExpM tv (Apply _ args ret _) = - mapM_ (walkOnSubExp tv . fst) args >> mapM_ (walkOnRetType tv) ret -walkExpM tv (BasicOp (Index arr slice)) = - walkOnVName tv arr >> mapM_ (traverse_ (walkOnSubExp tv)) slice -walkExpM tv (BasicOp (Update arr slice se)) = - walkOnVName tv arr >> - mapM_ (traverse_ (walkOnSubExp tv)) slice >> - walkOnSubExp tv se -walkExpM tv (BasicOp (Iota n x s _)) = - walkOnSubExp tv n >> walkOnSubExp tv x >> walkOnSubExp tv s -walkExpM tv (BasicOp (Replicate shape vexp)) = - walkOnShape tv shape >> walkOnSubExp tv vexp -walkExpM tv (BasicOp (Repeat shapes innershape v)) = - mapM_ (walkOnShape tv) shapes >> walkOnShape tv innershape >> walkOnVName tv v -walkExpM tv (BasicOp (Scratch _ shape)) = - mapM_ (walkOnSubExp tv) shape -walkExpM tv (BasicOp (Reshape shape arrexp)) = - mapM_ (traverse_ (walkOnSubExp tv)) shape >> walkOnVName tv arrexp -walkExpM tv (BasicOp (Rearrange _ e)) = - walkOnVName tv e -walkExpM tv (BasicOp (Rotate es e)) = - mapM_ (walkOnSubExp tv) es >> walkOnVName tv e -walkExpM tv (BasicOp (Concat _ x ys size)) = - walkOnVName tv x >> mapM_ (walkOnVName tv) ys >> walkOnSubExp tv size -walkExpM tv (BasicOp (Copy e)) = - walkOnVName tv e -walkExpM tv (BasicOp (Manifest _ e)) = - walkOnVName tv e -walkExpM tv (BasicOp (Assert e msg _)) = - walkOnSubExp tv e >> traverse_ (walkOnSubExp tv) msg -walkExpM tv (BasicOp (Opaque e)) = - walkOnSubExp tv e -walkExpM tv (DoLoop ctxmerge valmerge form loopbody) = do - mapM_ (walkOnFParam tv) ctxparams - mapM_ (walkOnFParam tv) valparams - walkOnLoopForm tv form - mapM_ (walkOnSubExp tv) ctxinits - mapM_ (walkOnSubExp tv) valinits - walkOnBody tv loopbody - where (ctxparams,ctxinits) = unzip ctxmerge - (valparams,valinits) = unzip valmerge -walkExpM tv (Op op) = - walkOnOp tv op diff --git a/src/Futhark/Representation/Aliases.hs b/src/Futhark/Representation/Aliases.hs deleted file mode 100644 --- a/src/Futhark/Representation/Aliases.hs +++ /dev/null @@ -1,362 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} --- | A representation where all bindings are annotated with aliasing --- information. -module Futhark.Representation.Aliases - ( -- * The Lore definition - Aliases - , Names' (..) - , VarAliases - , ConsumedInExp - , BodyAliasing - , module Futhark.Representation.AST.Attributes.Aliases - -- * Module re-exports - , module Futhark.Representation.AST.Attributes - , module Futhark.Representation.AST.Traversals - , module Futhark.Representation.AST.Pretty - , module Futhark.Representation.AST.Syntax - -- * Adding aliases - , addAliasesToPattern - , mkAliasedLetStm - , mkAliasedBody - , mkPatternAliases - , mkBodyAliases - -- * Removing aliases - , removeProgAliases - , removeFunDefAliases - , removeExpAliases - , removeStmAliases - , removeLambdaAliases - , removePatternAliases - , removeScopeAliases - -- * Tracking aliases - , AliasesAndConsumed - , trackAliases - , consumedInStms - ) -where - -import Control.Monad.Identity -import Control.Monad.Reader -import Data.Maybe -import qualified Data.Map.Strict as M - -import Futhark.Representation.AST.Syntax -import Futhark.Representation.AST.Attributes -import Futhark.Representation.AST.Attributes.Aliases -import Futhark.Representation.AST.Traversals -import Futhark.Representation.AST.Pretty -import Futhark.Transform.Rename -import Futhark.Binder -import Futhark.Transform.Substitute -import Futhark.Analysis.Rephrase -import qualified Futhark.Util.Pretty as PP - --- | The lore for the basic representation. -data Aliases lore - --- | A wrapper around 'Names' to get around the fact that we need an --- 'Ord' instance, which 'Names' does not have. -newtype Names' = Names' { unNames :: Names } - deriving (Show) - -instance Semigroup Names' where - x <> y = Names' $ unNames x <> unNames y - -instance Monoid Names' where - mempty = Names' mempty - -instance Eq Names' where - _ == _ = True - -instance Ord Names' where - _ `compare` _ = EQ - -instance Rename Names' where - rename (Names' names) = Names' <$> rename names - -instance Substitute Names' where - substituteNames substs (Names' names) = Names' $ substituteNames substs names - -instance FreeIn Names' where - freeIn' = const mempty - -instance PP.Pretty Names' where - ppr = PP.commasep . map PP.ppr . namesToList . unNames - --- | The aliases of the let-bound variable. -type VarAliases = Names' - --- | Everything consumed in the expression. -type ConsumedInExp = Names' - --- | The aliases of what is returned by the 'Body', and what is --- consumed inside of it. -type BodyAliasing = ([VarAliases], ConsumedInExp) - -instance (Annotations lore, CanBeAliased (Op lore)) => - Annotations (Aliases lore) where - type LetAttr (Aliases lore) = (VarAliases, LetAttr lore) - type ExpAttr (Aliases lore) = (ConsumedInExp, ExpAttr lore) - type BodyAttr (Aliases lore) = (BodyAliasing, BodyAttr lore) - type FParamAttr (Aliases lore) = FParamAttr lore - type LParamAttr (Aliases lore) = LParamAttr lore - type RetType (Aliases lore) = RetType lore - type BranchType (Aliases lore) = BranchType lore - type Op (Aliases lore) = OpWithAliases (Op lore) - -instance AliasesOf (VarAliases, attr) where - aliasesOf = unNames . fst - -instance FreeAttr Names' where - -withoutAliases :: (HasScope (Aliases lore) m, Monad m) => - ReaderT (Scope lore) m a -> m a -withoutAliases m = do - scope <- asksScope removeScopeAliases - runReaderT m scope - -instance (Attributes lore, CanBeAliased (Op lore)) => Attributes (Aliases lore) where - expTypesFromPattern = - withoutAliases . expTypesFromPattern . removePatternAliases - -instance (Attributes lore, CanBeAliased (Op lore)) => Aliased (Aliases lore) where - bodyAliases = map unNames . fst . fst . bodyAttr - consumedInBody = unNames . snd . fst . bodyAttr - -instance PrettyAnnot (PatElemT attr) => - PrettyAnnot (PatElemT (VarAliases, attr)) where - - ppAnnot (PatElem name (Names' als, attr)) = - let alias_comment = PP.oneLine <$> aliasComment name als - in case (alias_comment, ppAnnot (PatElem name attr)) of - (_, Nothing) -> - alias_comment - (Just alias_comment', Just inner_comment) -> - Just $ alias_comment' PP. inner_comment - (Nothing, Just inner_comment) -> - Just inner_comment - - -instance (Attributes lore, CanBeAliased (Op lore)) => PrettyLore (Aliases lore) where - ppExpLore (consumed, inner) e = - maybeComment $ catMaybes [expAttr, - mergeAttr, - ppExpLore inner $ removeExpAliases e] - where mergeAttr = - case e of - DoLoop _ merge _ body -> - let mergeParamAliases fparam als - | primType (paramType fparam) = - Nothing - | otherwise = - resultAliasComment (paramName fparam) als - in maybeComment $ catMaybes $ - zipWith mergeParamAliases (map fst merge) $ - bodyAliases body - _ -> Nothing - - expAttr = case namesToList $ unNames consumed of - [] -> Nothing - als -> Just $ PP.oneLine $ - PP.text "-- Consumes " <> PP.commasep (map PP.ppr als) - -maybeComment :: [PP.Doc] -> Maybe PP.Doc -maybeComment [] = Nothing -maybeComment cs = Just $ PP.folddoc (PP.) cs - -aliasComment :: PP.Pretty a => a -> Names -> Maybe PP.Doc -aliasComment name als = - case namesToList als of - [] -> Nothing - als' -> Just $ PP.oneLine $ - PP.text "-- " <> PP.ppr name <> PP.text " aliases " <> - PP.commasep (map PP.ppr als') - -resultAliasComment :: PP.Pretty a => a -> Names -> Maybe PP.Doc -resultAliasComment name als = - case namesToList als of - [] -> Nothing - als' -> Just $ PP.oneLine $ - PP.text "-- Result of " <> PP.ppr name <> PP.text " aliases " <> - PP.commasep (map PP.ppr als') - -removeAliases :: CanBeAliased (Op lore) => Rephraser Identity (Aliases lore) lore -removeAliases = Rephraser { rephraseExpLore = return . snd - , rephraseLetBoundLore = return . snd - , rephraseBodyLore = return . snd - , rephraseFParamLore = return - , rephraseLParamLore = return - , rephraseRetType = return - , rephraseBranchType = return - , rephraseOp = return . removeOpAliases - } - -removeScopeAliases :: Scope (Aliases lore) -> Scope lore -removeScopeAliases = M.map unAlias - where unAlias (LetInfo (_, attr)) = LetInfo attr - unAlias (FParamInfo attr) = FParamInfo attr - unAlias (LParamInfo attr) = LParamInfo attr - unAlias (IndexInfo it) = IndexInfo it - -removeProgAliases :: CanBeAliased (Op lore) => - Prog (Aliases lore) -> Prog lore -removeProgAliases = runIdentity . rephraseProg removeAliases - -removeFunDefAliases :: CanBeAliased (Op lore) => - FunDef (Aliases lore) -> FunDef lore -removeFunDefAliases = runIdentity . rephraseFunDef removeAliases - -removeExpAliases :: CanBeAliased (Op lore) => - Exp (Aliases lore) -> Exp lore -removeExpAliases = runIdentity . rephraseExp removeAliases - -removeStmAliases :: CanBeAliased (Op lore) => - Stm (Aliases lore) -> Stm lore -removeStmAliases = runIdentity . rephraseStm removeAliases - -removeLambdaAliases :: CanBeAliased (Op lore) => - Lambda (Aliases lore) -> Lambda lore -removeLambdaAliases = runIdentity . rephraseLambda removeAliases - -removePatternAliases :: PatternT (Names', a) - -> PatternT a -removePatternAliases = runIdentity . rephrasePattern (return . snd) - -addAliasesToPattern :: (Attributes lore, CanBeAliased (Op lore), Typed attr) => - PatternT attr -> Exp (Aliases lore) - -> PatternT (VarAliases, attr) -addAliasesToPattern pat e = - uncurry Pattern $ mkPatternAliases pat e - -mkAliasedBody :: (Attributes lore, CanBeAliased (Op lore)) => - BodyAttr lore -> Stms (Aliases lore) -> Result -> Body (Aliases lore) -mkAliasedBody innerlore bnds res = - Body (mkBodyAliases bnds res, innerlore) bnds res - -mkPatternAliases :: (Aliased lore, Typed attr) => - PatternT attr -> Exp lore - -> ([PatElemT (VarAliases, attr)], - [PatElemT (VarAliases, attr)]) -mkPatternAliases pat e = - -- Some part of the pattern may be the context. This does not have - -- aliases from expAliases, so we use a hack to compute aliases of - -- the context. - let als = expAliases e ++ repeat mempty -- In case the pattern has - -- more elements (this - -- implies a type error). - context_als = mkContextAliases pat e - in (zipWith annotateBindee (patternContextElements pat) context_als, - zipWith annotateBindee (patternValueElements pat) als) - where annotateBindee bindee names = - bindee `setPatElemLore` (Names' names', patElemAttr bindee) - where names' = - case patElemType bindee of - Array {} -> names - Mem _ -> names - _ -> mempty - -mkContextAliases :: Aliased lore => - PatternT attr -> Exp lore -> [Names] -mkContextAliases pat (DoLoop ctxmerge valmerge _ body) = - let ctx = map fst ctxmerge - init_als = zip mergenames $ map (subExpAliases . snd) $ ctxmerge ++ valmerge - expand als = als <> mconcat (mapMaybe (`lookup` init_als) (namesToList als)) - merge_als = zip mergenames $ - map ((`namesSubtract` mergenames_set) . expand) $ - bodyAliases body - in if length ctx == length (patternContextElements pat) - then map (fromMaybe mempty . flip lookup merge_als . paramName) ctx - else map (const mempty) $ patternContextElements pat - where mergenames = map (paramName . fst) $ ctxmerge ++ valmerge - mergenames_set = namesFromList mergenames -mkContextAliases pat (If _ tbranch fbranch _) = - take (length $ patternContextNames pat) $ - zipWith (<>) (bodyAliases tbranch) (bodyAliases fbranch) -mkContextAliases pat _ = - replicate (length $ patternContextElements pat) mempty - -mkBodyAliases :: Aliased lore => - Stms lore - -> Result - -> BodyAliasing -mkBodyAliases bnds res = - -- We need to remove the names that are bound in bnds from the alias - -- and consumption sets. We do this by computing the transitive - -- closure of the alias map (within bnds), then removing anything - -- bound in bnds. - let (aliases, consumed) = mkStmsAliases bnds res - boundNames = - foldMap (namesFromList . patternNames . stmPattern) bnds - aliases' = map (`namesSubtract` boundNames) aliases - consumed' = consumed `namesSubtract` boundNames - in (map Names' aliases', Names' consumed') - -mkStmsAliases :: Aliased lore => - Stms lore -> [SubExp] - -> ([Names], Names) -mkStmsAliases bnds res = delve mempty $ stmsToList bnds - where delve (aliasmap, consumed) [] = - (map (aliasClosure aliasmap . subExpAliases) res, - consumed) - delve (aliasmap, consumed) (bnd:bnds') = - delve (trackAliases (aliasmap, consumed) bnd) bnds' - aliasClosure aliasmap names = - names <> mconcat (map look $ namesToList names) - where look k = M.findWithDefault mempty k aliasmap - --- | Everything consumed in the given statements and result (even --- transitively). -consumedInStms :: Aliased lore => Stms lore -> Names -consumedInStms = snd . flip mkStmsAliases [] - -type AliasesAndConsumed = (M.Map VName Names, - Names) - -trackAliases :: Aliased lore => - AliasesAndConsumed -> Stm lore - -> AliasesAndConsumed -trackAliases (aliasmap, consumed) bnd = - let pat = stmPattern bnd - als = M.fromList $ - zip (patternNames pat) (map addAliasesOfAliases $ patternAliases pat) - aliasmap' = als <> aliasmap - consumed' = consumed <> addAliasesOfAliases (consumedInStm bnd) - in (aliasmap', consumed') - where addAliasesOfAliases names = names <> aliasesOfAliases names - aliasesOfAliases = mconcat . map look . namesToList - look k = M.findWithDefault mempty k aliasmap - -mkAliasedLetStm :: (Attributes lore, CanBeAliased (Op lore)) => - Pattern lore - -> StmAux (ExpAttr lore) -> Exp (Aliases lore) - -> Stm (Aliases lore) -mkAliasedLetStm pat (StmAux cs attr) e = - Let (addAliasesToPattern pat e) - (StmAux cs (Names' $ consumedInExp e, attr)) - e - -instance (Bindable lore, CanBeAliased (Op lore)) => Bindable (Aliases lore) where - mkExpAttr pat e = - let attr = mkExpAttr (removePatternAliases pat) $ removeExpAliases e - in (Names' $ consumedInExp e, attr) - - mkExpPat ctx val e = - addAliasesToPattern (mkExpPat ctx val $ removeExpAliases e) e - - mkLetNames names e = do - env <- asksScope removeScopeAliases - flip runReaderT env $ do - Let pat attr _ <- mkLetNames names $ removeExpAliases e - return $ mkAliasedLetStm pat attr e - - mkBody bnds res = - let Body bodylore _ _ = mkBody (fmap removeStmAliases bnds) res - in mkAliasedBody bodylore bnds res - -instance (Attributes (Aliases lore), Bindable (Aliases lore)) => BinderOps (Aliases lore) where - mkBodyB = bindableMkBodyB - mkExpAttrB = bindableMkExpAttrB - mkLetNamesB = bindableMkLetNamesB diff --git a/src/Futhark/Representation/Kernels.hs b/src/Futhark/Representation/Kernels.hs deleted file mode 100644 --- a/src/Futhark/Representation/Kernels.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} --- | A representation with flat parallelism via GPU-oriented kernels. -module Futhark.Representation.Kernels - ( -- * The Lore definition - Kernels - -- * Module re-exports - , module Futhark.Representation.AST.Attributes - , module Futhark.Representation.AST.Traversals - , module Futhark.Representation.AST.Pretty - , module Futhark.Representation.AST.Syntax - , module Futhark.Representation.Kernels.Kernel - , module Futhark.Representation.Kernels.Sizes - , module Futhark.Representation.SOACS.SOAC - ) -where - -import Futhark.Representation.AST.Syntax -import Futhark.Representation.Kernels.Kernel -import Futhark.Representation.Kernels.Sizes -import Futhark.Representation.AST.Attributes -import Futhark.Representation.AST.Traversals -import Futhark.Representation.AST.Pretty -import Futhark.Representation.SOACS.SOAC hiding (HistOp(..)) -import Futhark.Binder -import Futhark.Construct -import qualified Futhark.TypeCheck as TypeCheck - -data Kernels - -instance Annotations Kernels where - type Op Kernels = HostOp Kernels (SOAC Kernels) -instance Attributes Kernels where - expTypesFromPattern = return . expExtTypesFromPattern - -instance TypeCheck.CheckableOp Kernels where - checkOp = typeCheckKernelsOp Nothing - where typeCheckKernelsOp lvl = - typeCheckHostOp (typeCheckKernelsOp . Just) lvl typeCheckSOAC - -instance TypeCheck.Checkable Kernels where - -instance Bindable Kernels where - mkBody = Body () - mkExpPat ctx val _ = basicPattern ctx val - mkExpAttr _ _ = () - mkLetNames = simpleMkLetNames - -instance BinderOps Kernels where - mkExpAttrB = bindableMkExpAttrB - mkBodyB = bindableMkBodyB - mkLetNamesB = bindableMkLetNamesB - -instance PrettyLore Kernels where - -instance HasSegOp Kernels where - type SegOpLevel Kernels = SegLevel - asSegOp (SegOp op) = Just op - asSegOp _ = Nothing - segOp = SegOp diff --git a/src/Futhark/Representation/Kernels/Kernel.hs b/src/Futhark/Representation/Kernels/Kernel.hs deleted file mode 100644 --- a/src/Futhark/Representation/Kernels/Kernel.hs +++ /dev/null @@ -1,347 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Futhark.Representation.Kernels.Kernel - ( -- * Size operations - SizeOp(..) - - -- * Host operations - , HostOp(..) - , typeCheckHostOp - - -- * SegOp refinements - , SegLevel(..) - - -- * Reexports - , module Futhark.Representation.Kernels.Sizes - , module Futhark.Representation.SegOp - ) -where - -import Futhark.Representation.AST -import qualified Futhark.Analysis.ScalExp as SE -import qualified Futhark.Analysis.SymbolTable as ST -import qualified Futhark.Util.Pretty as PP -import Futhark.Util.Pretty - ((), (<+>), ppr, commasep, parens, text) -import Futhark.Transform.Substitute -import Futhark.Transform.Rename -import Futhark.Optimise.Simplify.Lore -import qualified Futhark.Optimise.Simplify.Engine as Engine -import Futhark.Representation.Ranges - (Ranges) -import Futhark.Representation.AST.Attributes.Ranges -import Futhark.Representation.AST.Attributes.Aliases -import Futhark.Representation.Aliases - (Aliases) -import Futhark.Representation.SegOp -import Futhark.Representation.Kernels.Sizes -import qualified Futhark.TypeCheck as TC -import Futhark.Analysis.Metrics - --- | At which level the *body* of a 'SegOp' executes. -data SegLevel = SegThread { segNumGroups :: Count NumGroups SubExp - , segGroupSize :: Count GroupSize SubExp - , segVirt :: SegVirt } - | SegGroup { segNumGroups :: Count NumGroups SubExp - , segGroupSize :: Count GroupSize SubExp - , segVirt :: SegVirt } - deriving (Eq, Ord, Show) - -instance PP.Pretty SegLevel where - ppr lvl = - lvl' - PP.parens (text "#groups=" <> ppr (segNumGroups lvl) <> PP.semi <+> - text "groupsize=" <> ppr (segGroupSize lvl) <> - case segVirt lvl of - SegNoVirt -> mempty - SegNoVirtFull -> PP.semi <+> text "full" - SegVirt -> PP.semi <+> text "virtualise") - - where lvl' = case lvl of SegThread{} -> "_thread" - SegGroup{} -> "_group" - -instance Engine.Simplifiable SegLevel where - simplify (SegThread num_groups group_size virt) = - SegThread <$> traverse Engine.simplify num_groups <*> - traverse Engine.simplify group_size <*> pure virt - simplify (SegGroup num_groups group_size virt) = - SegGroup <$> traverse Engine.simplify num_groups <*> - traverse Engine.simplify group_size <*> pure virt - -instance Substitute SegLevel where - substituteNames substs (SegThread num_groups group_size virt) = - SegThread - (substituteNames substs num_groups) (substituteNames substs group_size) virt - substituteNames substs (SegGroup num_groups group_size virt) = - SegGroup - (substituteNames substs num_groups) (substituteNames substs group_size) virt - -instance Rename SegLevel where - rename = substituteRename - -instance FreeIn SegLevel where - freeIn' (SegThread num_groups group_size _) = - freeIn' num_groups <> freeIn' group_size - freeIn' (SegGroup num_groups group_size _) = - freeIn' num_groups <> freeIn' group_size - --- | A simple size-level query or computation. -data SizeOp - = SplitSpace SplitOrdering SubExp SubExp SubExp - -- ^ @SplitSpace o w i elems_per_thread@. - -- - -- Computes how to divide array elements to - -- threads in a kernel. Returns the number of - -- elements in the chunk that the current thread - -- should take. - -- - -- @w@ is the length of the outer dimension in - -- the array. @i@ is the current thread - -- index. Each thread takes at most - -- @elems_per_thread@ elements. - -- - -- If the order @o@ is 'SplitContiguous', thread with index @i@ - -- should receive elements - -- @i*elems_per_tread, i*elems_per_thread + 1, - -- ..., i*elems_per_thread + (elems_per_thread-1)@. - -- - -- If the order @o@ is @'SplitStrided' stride@, - -- the thread will receive elements @i, - -- i+stride, i+2*stride, ..., - -- i+(elems_per_thread-1)*stride@. - | GetSize Name SizeClass - -- ^ Produce some runtime-configurable size. - | GetSizeMax SizeClass - -- ^ The maximum size of some class. - | CmpSizeLe Name SizeClass SubExp - -- ^ Compare size (likely a threshold) with some integer value. - | CalcNumGroups SubExp Name SubExp - -- ^ @CalcNumGroups w max_num_groups group_size@ calculates the - -- number of GPU workgroups to use for an input of the given size. - -- The @Name@ is a size name. Note that @w@ is an i64 to avoid - -- overflow issues. - deriving (Eq, Ord, Show) - -instance Substitute SizeOp where - substituteNames subst (SplitSpace o w i elems_per_thread) = - SplitSpace - (substituteNames subst o) - (substituteNames subst w) - (substituteNames subst i) - (substituteNames subst elems_per_thread) - substituteNames substs (CmpSizeLe name sclass x) = - CmpSizeLe name sclass (substituteNames substs x) - substituteNames substs (CalcNumGroups w max_num_groups group_size) = - CalcNumGroups - (substituteNames substs w) - max_num_groups - (substituteNames substs group_size) - substituteNames _ op = op - -instance Rename SizeOp where - rename (SplitSpace o w i elems_per_thread) = - SplitSpace - <$> rename o - <*> rename w - <*> rename i - <*> rename elems_per_thread - rename (CmpSizeLe name sclass x) = - CmpSizeLe name sclass <$> rename x - rename (CalcNumGroups w max_num_groups group_size) = - CalcNumGroups <$> rename w <*> pure max_num_groups <*> rename group_size - rename x = pure x - -instance IsOp SizeOp where - safeOp _ = True - cheapOp _ = True - -instance TypedOp SizeOp where - opType SplitSpace{} = pure [Prim int32] - opType (GetSize _ _) = pure [Prim int32] - opType (GetSizeMax _) = pure [Prim int32] - opType CmpSizeLe{} = pure [Prim Bool] - opType CalcNumGroups{} = pure [Prim int32] - -instance AliasedOp SizeOp where - opAliases _ = [mempty] - consumedInOp _ = mempty - -instance RangedOp SizeOp where - opRanges (SplitSpace _ _ _ elems_per_thread) = - [(Just (ScalarBound 0), - Just (ScalarBound (SE.subExpToScalExp elems_per_thread int32)))] - opRanges _ = [unknownRange] - -instance FreeIn SizeOp where - freeIn' (SplitSpace o w i elems_per_thread) = - freeIn' o <> freeIn' [w, i, elems_per_thread] - freeIn' (CmpSizeLe _ _ x) = freeIn' x - freeIn' (CalcNumGroups w _ group_size) = freeIn' w <> freeIn' group_size - freeIn' _ = mempty - -instance PP.Pretty SizeOp where - ppr (SplitSpace o w i elems_per_thread) = - text "splitSpace" <> suff <> - parens (commasep [ppr w, ppr i, ppr elems_per_thread]) - where suff = case o of SplitContiguous -> mempty - SplitStrided stride -> text "Strided" <> parens (ppr stride) - - ppr (GetSize name size_class) = - text "get_size" <> parens (commasep [ppr name, ppr size_class]) - - ppr (GetSizeMax size_class) = - text "get_size_max" <> parens (commasep [ppr size_class]) - - ppr (CmpSizeLe name size_class x) = - text "get_size" <> parens (commasep [ppr name, ppr size_class]) <+> - text "<=" <+> ppr x - - ppr (CalcNumGroups w max_num_groups group_size) = - text "calc_num_groups" <> parens (commasep [ppr w, ppr max_num_groups, ppr group_size]) - -instance OpMetrics SizeOp where - opMetrics SplitSpace{} = seen "SplitSpace" - opMetrics GetSize{} = seen "GetSize" - opMetrics GetSizeMax{} = seen "GetSizeMax" - opMetrics CmpSizeLe{} = seen "CmpSizeLe" - opMetrics CalcNumGroups{} = seen "CalcNumGroups" - -typeCheckSizeOp :: TC.Checkable lore => SizeOp -> TC.TypeM lore () -typeCheckSizeOp (SplitSpace o w i elems_per_thread) = do - case o of - SplitContiguous -> return () - SplitStrided stride -> TC.require [Prim int32] stride - mapM_ (TC.require [Prim int32]) [w, i, elems_per_thread] -typeCheckSizeOp GetSize{} = return () -typeCheckSizeOp GetSizeMax{} = return () -typeCheckSizeOp (CmpSizeLe _ _ x) = TC.require [Prim int32] x -typeCheckSizeOp (CalcNumGroups w _ group_size) = do TC.require [Prim int64] w - TC.require [Prim int32] group_size - --- | A host-level operation; parameterised by what else it can do. -data HostOp lore op - = SegOp (SegOp SegLevel lore) - -- ^ A segmented operation. - | SizeOp SizeOp - | OtherOp op - deriving (Eq, Ord, Show) - -instance (Attributes lore, Substitute op) => Substitute (HostOp lore op) where - substituteNames substs (SegOp op) = - SegOp $ substituteNames substs op - substituteNames substs (OtherOp op) = - OtherOp $ substituteNames substs op - substituteNames substs (SizeOp op) = - SizeOp $ substituteNames substs op - -instance (Attributes lore, Rename op) => Rename (HostOp lore op) where - rename (SegOp op) = SegOp <$> rename op - rename (OtherOp op) = OtherOp <$> rename op - rename (SizeOp op) = SizeOp <$> rename op - -instance (Attributes lore, IsOp op) => IsOp (HostOp lore op) where - safeOp (SegOp op) = safeOp op - safeOp (OtherOp op) = safeOp op - safeOp (SizeOp op) = safeOp op - - cheapOp (SegOp op) = cheapOp op - cheapOp (OtherOp op) = cheapOp op - cheapOp (SizeOp op) = cheapOp op - -instance TypedOp op => TypedOp (HostOp lore op) where - opType (SegOp op) = opType op - opType (OtherOp op) = opType op - opType (SizeOp op) = opType op - -instance (Aliased lore, AliasedOp op, Attributes lore) => AliasedOp (HostOp lore op) where - opAliases (SegOp op) = opAliases op - opAliases (OtherOp op) = opAliases op - opAliases (SizeOp op) = opAliases op - - consumedInOp (SegOp op) = consumedInOp op - consumedInOp (OtherOp op) = consumedInOp op - consumedInOp (SizeOp op) = consumedInOp op - -instance (Attributes lore, RangedOp op) => RangedOp (HostOp lore op) where - opRanges (SegOp op) = opRanges op - opRanges (OtherOp op) = opRanges op - opRanges (SizeOp op) = opRanges op - -instance (Attributes lore, FreeIn op) => FreeIn (HostOp lore op) where - freeIn' (SegOp op) = freeIn' op - freeIn' (OtherOp op) = freeIn' op - freeIn' (SizeOp op) = freeIn' op - -instance (CanBeAliased (Op lore), CanBeAliased op, Attributes lore) => CanBeAliased (HostOp lore op) where - type OpWithAliases (HostOp lore op) = HostOp (Aliases lore) (OpWithAliases op) - - addOpAliases (SegOp op) = SegOp $ addOpAliases op - addOpAliases (OtherOp op) = OtherOp $ addOpAliases op - addOpAliases (SizeOp op) = SizeOp op - - removeOpAliases (SegOp op) = SegOp $ removeOpAliases op - removeOpAliases (OtherOp op) = OtherOp $ removeOpAliases op - removeOpAliases (SizeOp op) = SizeOp op - -instance (CanBeRanged (Op lore), CanBeRanged op, Attributes lore) => CanBeRanged (HostOp lore op) where - type OpWithRanges (HostOp lore op) = HostOp (Ranges lore) (OpWithRanges op) - - addOpRanges (SegOp op) = SegOp $ addOpRanges op - addOpRanges (OtherOp op) = OtherOp $ addOpRanges op - addOpRanges (SizeOp op) = SizeOp op - - removeOpRanges (SegOp op) = SegOp $ removeOpRanges op - removeOpRanges (OtherOp op) = OtherOp $ removeOpRanges op - removeOpRanges (SizeOp op) = SizeOp op - -instance (CanBeWise (Op lore), CanBeWise op, Attributes lore) => CanBeWise (HostOp lore op) where - type OpWithWisdom (HostOp lore op) = HostOp (Wise lore) (OpWithWisdom op) - - removeOpWisdom (SegOp op) = SegOp $ removeOpWisdom op - removeOpWisdom (OtherOp op) = OtherOp $ removeOpWisdom op - removeOpWisdom (SizeOp op) = SizeOp op - -instance (Attributes lore, ST.IndexOp op) => ST.IndexOp (HostOp lore op) where - indexOp vtable k (SegOp op) is = ST.indexOp vtable k op is - indexOp vtable k (OtherOp op) is = ST.indexOp vtable k op is - indexOp _ _ _ _ = Nothing - -instance (PrettyLore lore, PP.Pretty op) => PP.Pretty (HostOp lore op) where - ppr (SegOp op) = ppr op - ppr (OtherOp op) = ppr op - ppr (SizeOp op) = ppr op - -instance (OpMetrics (Op lore), OpMetrics op) => OpMetrics (HostOp lore op) where - opMetrics (SegOp op) = opMetrics op - opMetrics (OtherOp op) = opMetrics op - opMetrics (SizeOp op) = opMetrics op - -checkSegLevel :: Maybe SegLevel -> SegLevel -> TC.TypeM lore () -checkSegLevel Nothing _ = - return () -checkSegLevel (Just SegThread{}) _ = - TC.bad $ TC.TypeError "SegOps cannot occur when already at thread level." -checkSegLevel (Just x) y - | x == y = TC.bad $ TC.TypeError $ "Already at at level " ++ pretty x - | segNumGroups x /= segNumGroups y || segGroupSize x /= segGroupSize y = - TC.bad $ TC.TypeError "Physical layout for SegLevel does not match parent SegLevel." - | otherwise = - return () - -typeCheckHostOp :: TC.Checkable lore => - (SegLevel -> OpWithAliases (Op lore) -> TC.TypeM lore ()) - -> Maybe SegLevel - -> (op -> TC.TypeM lore ()) - -> HostOp (Aliases lore) op - -> TC.TypeM lore () -typeCheckHostOp checker lvl _ (SegOp op) = - TC.checkOpWith (checker $ segLevel op) $ - typeCheckSegOp (checkSegLevel lvl) op -typeCheckHostOp _ _ f (OtherOp op) = f op -typeCheckHostOp _ _ _ (SizeOp op) = typeCheckSizeOp op diff --git a/src/Futhark/Representation/Kernels/Simplify.hs b/src/Futhark/Representation/Kernels/Simplify.hs deleted file mode 100644 --- a/src/Futhark/Representation/Kernels/Simplify.hs +++ /dev/null @@ -1,100 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ConstraintKinds #-} -module Futhark.Representation.Kernels.Simplify - ( simplifyKernels - , simplifyLambda - - , Kernels - - -- * Building blocks - , simplifyKernelOp - ) -where - -import Futhark.Representation.Kernels -import qualified Futhark.Optimise.Simplify.Engine as Engine -import Futhark.Optimise.Simplify.Rules -import Futhark.Optimise.Simplify.Lore -import Futhark.MonadFreshNames -import Futhark.Tools -import Futhark.Pass -import Futhark.Representation.SOACS.Simplify (simplifySOAC) -import qualified Futhark.Optimise.Simplify as Simplify -import Futhark.Optimise.Simplify.Rule -import qualified Futhark.Analysis.SymbolTable as ST -import qualified Futhark.Transform.FirstOrderTransform as FOT - -simpleKernels :: Simplify.SimpleOps Kernels -simpleKernels = Simplify.bindableSimpleOps $ simplifyKernelOp simplifySOAC - -simplifyKernels :: Prog Kernels -> PassM (Prog Kernels) -simplifyKernels = - Simplify.simplifyProg simpleKernels kernelRules Simplify.noExtraHoistBlockers - -simplifyLambda :: (HasScope Kernels m, MonadFreshNames m) => - Lambda Kernels -> [Maybe VName] -> m (Lambda Kernels) -simplifyLambda = - Simplify.simplifyLambda simpleKernels kernelRules Engine.noExtraHoistBlockers - -simplifyKernelOp :: (Engine.SimplifiableLore lore, - BodyAttr lore ~ ()) => - Simplify.SimplifyOp lore op - -> HostOp lore op - -> Engine.SimpleM lore (HostOp (Wise lore) (OpWithWisdom op), Stms (Wise lore)) - -simplifyKernelOp f (OtherOp op) = do - (op', stms) <- f op - return (OtherOp op', stms) - -simplifyKernelOp _ (SegOp op) = do - (op', hoisted) <- simplifySegOp op - return (SegOp op', hoisted) - -simplifyKernelOp _ (SizeOp (SplitSpace o w i elems_per_thread)) = - (,) <$> (SizeOp <$> - (SplitSpace <$> Engine.simplify o <*> Engine.simplify w - <*> Engine.simplify i <*> Engine.simplify elems_per_thread)) - <*> pure mempty -simplifyKernelOp _ (SizeOp (GetSize key size_class)) = - return (SizeOp $ GetSize key size_class, mempty) -simplifyKernelOp _ (SizeOp (GetSizeMax size_class)) = - return (SizeOp $ GetSizeMax size_class, mempty) -simplifyKernelOp _ (SizeOp (CmpSizeLe key size_class x)) = do - x' <- Engine.simplify x - return (SizeOp $ CmpSizeLe key size_class x', mempty) -simplifyKernelOp _ (SizeOp (CalcNumGroups w max_num_groups group_size)) = do - w' <- Engine.simplify w - return (SizeOp $ CalcNumGroups w' max_num_groups group_size, mempty) - -instance BinderOps (Wise Kernels) where - mkExpAttrB = bindableMkExpAttrB - mkBodyB = bindableMkBodyB - mkLetNamesB = bindableMkLetNamesB - -instance HasSegOp (Wise Kernels) where - type SegOpLevel (Wise Kernels) = SegLevel - asSegOp (SegOp op) = Just op - asSegOp _ = Nothing - segOp = SegOp - -kernelRules :: RuleBook (Wise Kernels) -kernelRules = standardRules <> segOpRules <> - ruleBook - [ RuleOp redomapIotaToLoop ] - [ RuleBasicOp removeUnnecessaryCopy ] - --- We turn reductions over (solely) iotas into do-loops, because there --- is no useful structure here anyway. This is mostly a hack to work --- around the fact that loop tiling would otherwise pointlessly tile --- them. -redomapIotaToLoop :: TopDownRuleOp (Wise Kernels) -redomapIotaToLoop vtable pat aux (OtherOp soac@(Screma _ form [arr])) - | Just _ <- isRedomapSOAC form, - Just (Iota{}, _) <- ST.lookupBasicOp arr vtable = - Simplify $ certifying (stmAuxCerts aux) $ FOT.transformSOAC pat soac -redomapIotaToLoop _ _ _ _ = - Skip diff --git a/src/Futhark/Representation/Kernels/Sizes.hs b/src/Futhark/Representation/Kernels/Sizes.hs deleted file mode 100644 --- a/src/Futhark/Representation/Kernels/Sizes.hs +++ /dev/null @@ -1,66 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -module Futhark.Representation.Kernels.Sizes - ( SizeClass (..) - , KernelPath - , Count(..) - , NumGroups, GroupSize, NumThreads - ) - where - -import Data.Int (Int32) -import Data.Traversable - -import Futhark.Util.Pretty -import Futhark.Transform.Substitute -import Language.Futhark.Core (Name) -import Futhark.Util.IntegralExp (IntegralExp) -import Futhark.Representation.AST.Attributes.Names (FreeIn) - --- | An indication of which comparisons have been performed to get to --- this point, as well as the result of each comparison. -type KernelPath = [(Name, Bool)] - --- | The class of some kind of configurable size. Each class may --- impose constraints on the valid values. -data SizeClass = SizeThreshold KernelPath - | SizeGroup - | SizeNumGroups - | SizeTile - | SizeLocalMemory - -- ^ Likely not useful on its own, but querying the - -- maximum can be handy. - | SizeBespoke Name Int32 - -- ^ A bespoke size with a default. - deriving (Eq, Ord, Show) - -instance Pretty SizeClass where - ppr (SizeThreshold path) = text $ "threshold (" ++ unwords (map pStep path) ++ ")" - where pStep (v, True) = pretty v - pStep (v, False) = '!' : pretty v - ppr SizeGroup = text "group_size" - ppr SizeNumGroups = text "num_groups" - ppr SizeTile = text "tile_size" - ppr SizeLocalMemory = text "local_memory" - ppr (SizeBespoke k _) = ppr k - --- | A wrapper supporting a phantom type for indicating what we are counting. -newtype Count u e = Count { unCount :: e } - deriving (Eq, Ord, Show, Num, IntegralExp, FreeIn, Pretty, Substitute) - -instance Functor (Count u) where - fmap = fmapDefault - -instance Foldable (Count u) where - foldMap = foldMapDefault - -instance Traversable (Count u) where - traverse f (Count x) = Count <$> f x - --- | Phantom type for the number of groups of some kernel. -data NumGroups - --- | Phantom type for the group size of some kernel. -data GroupSize - --- | Phantom type for number of threads. -data NumThreads diff --git a/src/Futhark/Representation/KernelsMem.hs b/src/Futhark/Representation/KernelsMem.hs deleted file mode 100644 --- a/src/Futhark/Representation/KernelsMem.hs +++ /dev/null @@ -1,96 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ConstraintKinds #-} -module Futhark.Representation.KernelsMem - ( KernelsMem - - -- * Simplification - , simplifyProg - , simplifyStms - , simpleKernelsMem - - -- * Module re-exports - , module Futhark.Representation.Mem - , module Futhark.Representation.Kernels.Kernel - ) - where - -import Futhark.Analysis.PrimExp.Convert -import Futhark.MonadFreshNames -import Futhark.Pass -import Futhark.Representation.AST.Syntax -import Futhark.Representation.AST.Attributes -import Futhark.Representation.AST.Traversals -import Futhark.Representation.AST.Pretty -import Futhark.Representation.Kernels.Kernel -import Futhark.Representation.Kernels.Simplify (simplifyKernelOp) -import qualified Futhark.TypeCheck as TC -import Futhark.Representation.Mem -import Futhark.Representation.Mem.Simplify -import Futhark.Pass.ExplicitAllocations (BinderOps(..), mkLetNamesB', mkLetNamesB'') -import qualified Futhark.Optimise.Simplify.Engine as Engine - -data KernelsMem - -instance Annotations KernelsMem where - type LetAttr KernelsMem = LetAttrMem - type FParamAttr KernelsMem = FParamMem - type LParamAttr KernelsMem = LParamMem - type RetType KernelsMem = RetTypeMem - type BranchType KernelsMem = BranchTypeMem - type Op KernelsMem = MemOp (HostOp KernelsMem ()) - -instance Attributes KernelsMem where - expTypesFromPattern = return . map snd . snd . bodyReturnsFromPattern - -instance OpReturns KernelsMem where - opReturns (Alloc _ space) = - return [MemMem space] - opReturns (Inner (SegOp op)) = segOpReturns op - opReturns k = extReturns <$> opType k - -instance PrettyLore KernelsMem where - -instance TC.CheckableOp KernelsMem where - checkOp = typeCheckMemoryOp Nothing - where typeCheckMemoryOp _ (Alloc size _) = - TC.require [Prim int64] size - typeCheckMemoryOp lvl (Inner op) = - typeCheckHostOp (typeCheckMemoryOp . Just) lvl (const $ return ()) op - -instance TC.Checkable KernelsMem where - checkFParamLore = checkMemInfo - checkLParamLore = checkMemInfo - checkLetBoundLore = checkMemInfo - checkRetType = mapM_ TC.checkExtType . retTypeValues - primFParam name t = return $ Param name (MemPrim t) - matchPattern = matchPatternToExp - matchReturnType = matchFunctionReturnType - matchBranchType = matchBranchReturnType - -instance BinderOps KernelsMem where - mkExpAttrB _ _ = return () - mkBodyB stms res = return $ Body () stms res - mkLetNamesB = mkLetNamesB' () - -instance BinderOps (Engine.Wise KernelsMem) where - mkExpAttrB pat e = return $ Engine.mkWiseExpAttr pat () e - mkBodyB stms res = return $ Engine.mkWiseBody () stms res - mkLetNamesB = mkLetNamesB'' - -simplifyProg :: Prog KernelsMem -> PassM (Prog KernelsMem) -simplifyProg = - simplifyProgGeneric $ simplifyKernelOp $ const $ return ((), mempty) - -simplifyStms :: (HasScope KernelsMem m, MonadFreshNames m) => - Stms KernelsMem - -> m (Engine.SymbolTable (Engine.Wise KernelsMem), - Stms KernelsMem) -simplifyStms = - simplifyStmsGeneric $ simplifyKernelOp $ const $ return ((), mempty) - -simpleKernelsMem :: Engine.SimpleOps KernelsMem -simpleKernelsMem = - simpleGeneric $ simplifyKernelOp $ const $ return ((), mempty) diff --git a/src/Futhark/Representation/Mem.hs b/src/Futhark/Representation/Mem.hs deleted file mode 100644 --- a/src/Futhark/Representation/Mem.hs +++ /dev/null @@ -1,997 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ConstraintKinds #-} --- | Building blocks for defining representations where every array --- is given information about which memory block is it based in, and --- how array elements map to memory block offsets. --- --- There are two primary concepts you will need to understand: --- --- 1. Memory blocks, which are Futhark values of type 'Mem' --- (parametrized with their size). These correspond to arbitrary --- blocks of memory, and are created using the 'Alloc' operation. --- --- 2. Index functions, which describe a mapping from the index space --- of an array (eg. a two-dimensional space for an array of type --- @[[int]]@) to a one-dimensional offset into a memory block. --- Thus, index functions describe how arbitrary-dimensional arrays --- are mapped to the single-dimensional world of memory. --- --- At a conceptual level, imagine that we have a two-dimensional array --- @a@ of 32-bit integers, consisting of @n@ rows of @m@ elements --- each. This array could be represented in classic row-major format --- with an index function like the following: --- --- @ --- f(i,j) = i * m + j --- @ --- --- When we want to know the location of element @a[2,3]@, we simply --- call the index function as @f(2,3)@ and obtain @2*m+3@. We could --- also have chosen another index function, one that represents the --- array in column-major (or "transposed") format: --- --- @ --- f(i,j) = j * n + i --- @ --- --- Index functions are not Futhark-level functions, but a special --- construct that the final code generator will eventually use to --- generate concrete access code. By modifying the index functions we --- can change how an array is represented in memory, which can permit --- memory access pattern optimisations. --- --- Every time we bind an array, whether in a @let@-binding, @loop@ --- merge parameter, or @lambda@ parameter, we have an annotation --- specifying a memory block and an index function. In some cases, --- such as @let@-bindings for many expressions, we are free to specify --- an arbitrary index function and memory block - for example, we get --- to decide where 'Copy' stores its result - but in other cases the --- type rules of the expression chooses for us. For example, 'Index' --- always produces an array in the same memory block as its input, and --- with the same index function, except with some indices fixed. -module Futhark.Representation.Mem - ( LetAttrMem - , FParamMem - , LParamMem - , RetTypeMem - , BranchTypeMem - - , MemOp (..) - , MemInfo (..) - , MemBound - , MemBind (..) - , MemReturn (..) - , IxFun - , ExtIxFun - , isStaticIxFun - , ExpReturns - , BodyReturns - , FunReturns - , noUniquenessReturns - , bodyReturnsToExpReturns - , Mem - , AllocOp(..) - , OpReturns(..) - , varReturns - , expReturns - , extReturns - , lookupMemInfo - , subExpMemInfo - , lookupArraySummary - , existentialiseIxFun - - -- * Type checking parts - , matchBranchReturnType - , matchPatternToExp - , matchFunctionReturnType - , bodyReturnsFromPattern - , checkMemInfo - - -- * Module re-exports - , module Futhark.Representation.AST.Attributes - , module Futhark.Representation.AST.Traversals - , module Futhark.Representation.AST.Pretty - , module Futhark.Representation.AST.Syntax - , module Futhark.Analysis.PrimExp.Convert - ) -where - -import Data.Maybe -import Control.Monad.State -import Control.Monad.Reader -import Control.Monad.Except -import qualified Data.Map.Strict as M -import Data.Foldable (traverse_, toList) -import Data.List (find) -import qualified Data.Set as S - -import Futhark.Analysis.Metrics -import Futhark.Representation.AST.Syntax -import Futhark.Representation.AST.Attributes -import Futhark.Representation.AST.Attributes.Aliases -import Futhark.Representation.AST.Traversals -import Futhark.Representation.AST.Pretty -import Futhark.Transform.Rename -import Futhark.Transform.Substitute -import qualified Futhark.TypeCheck as TC -import qualified Futhark.Representation.Mem.IxFun as IxFun -import Futhark.Analysis.PrimExp.Convert -import Futhark.Analysis.PrimExp.Simplify -import Futhark.Util -import qualified Futhark.Util.Pretty as PP -import qualified Futhark.Optimise.Simplify.Engine as Engine -import Futhark.Optimise.Simplify.Lore -import Futhark.Representation.Aliases - (Aliases, removeScopeAliases, removeExpAliases, removePatternAliases) -import Futhark.Representation.AST.Attributes.Ranges -import qualified Futhark.Analysis.SymbolTable as ST - -type LetAttrMem = MemInfo SubExp NoUniqueness MemBind -type FParamMem = MemInfo SubExp Uniqueness MemBind -type LParamMem = MemInfo SubExp NoUniqueness MemBind -type RetTypeMem = FunReturns -type BranchTypeMem = BodyReturns - --- | The class of ops that have memory allocation. -class AllocOp op where - allocOp :: SubExp -> Space -> op - -type Mem lore = (AllocOp (Op lore), - FParamAttr lore ~ FParamMem, - LParamAttr lore ~ LParamMem, - LetAttr lore ~ LetAttrMem, - RetType lore ~ RetTypeMem, - BranchType lore ~ BranchTypeMem, - CanBeAliased (Op lore), - Attributes lore, Annotations lore, - TC.Checkable lore, - OpReturns lore) - -instance IsRetType FunReturns where - primRetType = MemPrim - applyRetType = applyFunReturns - -instance IsBodyType BodyReturns where - primBodyType = MemPrim - -data MemOp inner = Alloc SubExp Space - -- ^ Allocate a memory block. This really should not be an - -- expression, but what are you gonna do... - | Inner inner - deriving (Eq, Ord, Show) - -instance AllocOp (MemOp inner) where - allocOp = Alloc - -instance FreeIn inner => FreeIn (MemOp inner) where - freeIn' (Alloc size _) = freeIn' size - freeIn' (Inner k) = freeIn' k - -instance TypedOp inner => TypedOp (MemOp inner) where - opType (Alloc _ space) = pure [Mem space] - opType (Inner k) = opType k - -instance AliasedOp inner => AliasedOp (MemOp inner) where - opAliases Alloc{} = [mempty] - opAliases (Inner k) = opAliases k - - consumedInOp Alloc{} = mempty - consumedInOp (Inner k) = consumedInOp k - -instance CanBeAliased inner => CanBeAliased (MemOp inner) where - type OpWithAliases (MemOp inner) = MemOp (OpWithAliases inner) - removeOpAliases (Alloc se space) = Alloc se space - removeOpAliases (Inner k) = Inner $ removeOpAliases k - - addOpAliases (Alloc se space) = Alloc se space - addOpAliases (Inner k) = Inner $ addOpAliases k - -instance RangedOp inner => RangedOp (MemOp inner) where - opRanges (Alloc _ _) = - [unknownRange] - opRanges (Inner k) = - opRanges k - -instance CanBeRanged inner => CanBeRanged (MemOp inner) where - type OpWithRanges (MemOp inner) = MemOp (OpWithRanges inner) - removeOpRanges (Alloc size space) = Alloc size space - removeOpRanges (Inner k) = Inner $ removeOpRanges k - - addOpRanges (Alloc size space) = Alloc size space - addOpRanges (Inner k) = Inner $ addOpRanges k - -instance Rename inner => Rename (MemOp inner) where - rename (Alloc size space) = Alloc <$> rename size <*> pure space - rename (Inner k) = Inner <$> rename k - -instance Substitute inner => Substitute (MemOp inner) where - substituteNames subst (Alloc size space) = Alloc (substituteNames subst size) space - substituteNames subst (Inner k) = Inner $ substituteNames subst k - -instance PP.Pretty inner => PP.Pretty (MemOp inner) where - ppr (Alloc e DefaultSpace) = PP.text "alloc" <> PP.apply [PP.ppr e] - ppr (Alloc e s) = PP.text "alloc" <> PP.apply [PP.ppr e, PP.ppr s] - ppr (Inner k) = PP.ppr k - -instance OpMetrics inner => OpMetrics (MemOp inner) where - opMetrics Alloc{} = seen "Alloc" - opMetrics (Inner k) = opMetrics k - -instance IsOp inner => IsOp (MemOp inner) where - safeOp Alloc{} = False - safeOp (Inner k) = safeOp k - cheapOp (Inner k) = cheapOp k - cheapOp Alloc{} = True - -instance CanBeWise inner => CanBeWise (MemOp inner) where - type OpWithWisdom (MemOp inner) = MemOp (OpWithWisdom inner) - removeOpWisdom (Alloc size space) = Alloc size space - removeOpWisdom (Inner k) = Inner $ removeOpWisdom k - -instance ST.IndexOp inner => ST.IndexOp (MemOp inner) where - indexOp vtable k (Inner op) is = ST.indexOp vtable k op is - indexOp _ _ _ _ = Nothing - --- | The index function representation used for memory annotations. -type IxFun = IxFun.IxFun (PrimExp VName) - --- | An index function that may contain existential variables. -type ExtIxFun = IxFun.IxFun (PrimExp (Ext VName)) - --- | A summary of the memory information for every let-bound --- identifier, function parameter, and return value. Parameterisered --- over uniqueness, dimension, and auxiliary array information. -data MemInfo d u ret = MemPrim PrimType - -- ^ A primitive value. - | MemMem Space - -- ^ A memory block. - | MemArray PrimType (ShapeBase d) u ret - -- ^ The array is stored in the named memory block, - -- and with the given index function. The index - -- function maps indices in the array to /element/ - -- offset, /not/ byte offsets! To translate to byte - -- offsets, multiply the offset with the size of the - -- array element type. - deriving (Eq, Show, Ord) --- XXX Ord? - -type MemBound u = MemInfo SubExp u MemBind - -instance FixExt ret => DeclExtTyped (MemInfo ExtSize Uniqueness ret) where - declExtTypeOf (MemPrim pt) = Prim pt - declExtTypeOf (MemMem space) = Mem space - declExtTypeOf (MemArray pt shape u _) = Array pt shape u - -instance FixExt ret => ExtTyped (MemInfo ExtSize NoUniqueness ret) where - extTypeOf (MemPrim pt) = Prim pt - extTypeOf (MemMem space) = Mem space - extTypeOf (MemArray pt shape u _) = Array pt shape u - -instance FixExt ret => FixExt (MemInfo ExtSize u ret) where - fixExt _ _ (MemPrim pt) = MemPrim pt - fixExt _ _ (MemMem space) = MemMem space - fixExt i se (MemArray pt shape u ret) = - MemArray pt (fixExt i se shape) u (fixExt i se ret) - -instance Typed (MemInfo SubExp Uniqueness ret) where - typeOf = fromDecl . declTypeOf - -instance Typed (MemInfo SubExp NoUniqueness ret) where - typeOf (MemPrim pt) = Prim pt - typeOf (MemMem space) = Mem space - typeOf (MemArray bt shape u _) = Array bt shape u - -instance DeclTyped (MemInfo SubExp Uniqueness ret) where - declTypeOf (MemPrim bt) = Prim bt - declTypeOf (MemMem space) = Mem space - declTypeOf (MemArray bt shape u _) = Array bt shape u - -instance (FreeIn d, FreeIn ret) => FreeIn (MemInfo d u ret) where - freeIn' (MemArray _ shape _ ret) = freeIn' shape <> freeIn' ret - freeIn' (MemMem s) = freeIn' s - freeIn' MemPrim{} = mempty - -instance (Substitute d, Substitute ret) => Substitute (MemInfo d u ret) where - substituteNames subst (MemArray bt shape u ret) = - MemArray bt - (substituteNames subst shape) u - (substituteNames subst ret) - substituteNames _ (MemMem space) = - MemMem space - substituteNames _ (MemPrim bt) = - MemPrim bt - -instance (Substitute d, Substitute ret) => Rename (MemInfo d u ret) where - rename = substituteRename - -simplifyIxFun :: Engine.SimplifiableLore lore => - IxFun -> Engine.SimpleM lore IxFun -simplifyIxFun = traverse simplifyPrimExp - -simplifyExtIxFun :: Engine.SimplifiableLore lore => - ExtIxFun -> Engine.SimpleM lore ExtIxFun -simplifyExtIxFun = traverse simplifyExtPrimExp - -isStaticIxFun :: ExtIxFun -> Maybe IxFun -isStaticIxFun = traverse $ traverse inst - where inst Ext{} = Nothing - inst (Free x) = Just x - -instance (Engine.Simplifiable d, Engine.Simplifiable ret) => - Engine.Simplifiable (MemInfo d u ret) where - simplify (MemPrim bt) = - return $ MemPrim bt - simplify (MemMem space) = - pure $ MemMem space - simplify (MemArray bt shape u ret) = - MemArray bt <$> Engine.simplify shape <*> pure u <*> Engine.simplify ret - -instance (PP.Pretty (TypeBase (ShapeBase d) u), - PP.Pretty d, PP.Pretty u, PP.Pretty ret) => PP.Pretty (MemInfo d u ret) where - ppr (MemPrim bt) = PP.ppr bt - ppr (MemMem DefaultSpace) = PP.text "mem" - ppr (MemMem s) = PP.text "mem" <> PP.ppr s - ppr (MemArray bt shape u ret) = - PP.ppr (Array bt shape u) <> PP.text "@" <> PP.ppr ret - -instance PP.Pretty (Param (MemInfo SubExp Uniqueness ret)) where - ppr = PP.ppr . fmap declTypeOf - -instance PP.Pretty (Param (MemInfo SubExp NoUniqueness ret)) where - ppr = PP.ppr . fmap typeOf - -instance PP.Pretty (PatElemT (MemInfo SubExp NoUniqueness ret)) where - ppr = PP.ppr . fmap typeOf - --- | Memory information for an array bound somewhere in the program. -data MemBind = ArrayIn VName IxFun - -- ^ Located in this memory block with this index - -- function. - deriving (Show) - -instance Eq MemBind where - _ == _ = True - -instance Ord MemBind where - _ `compare` _ = EQ - -instance Rename MemBind where - rename = substituteRename - -instance Substitute MemBind where - substituteNames substs (ArrayIn ident ixfun) = - ArrayIn (substituteNames substs ident) (substituteNames substs ixfun) - -instance PP.Pretty MemBind where - ppr (ArrayIn mem ixfun) = - PP.text "@" <> PP.ppr mem <> PP.text "->" <> PP.ppr ixfun - -instance FreeIn MemBind where - freeIn' (ArrayIn mem ixfun) = freeIn' mem <> freeIn' ixfun - --- | A description of the memory properties of an array being returned --- by an operation. -data MemReturn = ReturnsInBlock VName ExtIxFun - -- ^ The array is located in a memory block that is - -- already in scope. - | ReturnsNewBlock Space Int ExtIxFun - -- ^ The operation returns a new (existential) memory - -- block. - deriving (Show) - -instance Eq MemReturn where - _ == _ = True - -instance Ord MemReturn where - _ `compare` _ = EQ - -instance Rename MemReturn where - rename = substituteRename - -instance Substitute MemReturn where - substituteNames substs (ReturnsInBlock ident ixfun) = - ReturnsInBlock (substituteNames substs ident) (substituteNames substs ixfun) - substituteNames substs (ReturnsNewBlock space i ixfun) = - ReturnsNewBlock space i (substituteNames substs ixfun) - -instance FixExt MemReturn where - fixExt i (Var v) (ReturnsNewBlock _ j ixfun) - | j == i = ReturnsInBlock v $ fixExtIxFun i - (primExpFromSubExp int32 (Var v)) ixfun - fixExt i se (ReturnsNewBlock space j ixfun) = - ReturnsNewBlock space j' - (fixExtIxFun i (primExpFromSubExp int32 se) ixfun) - where j' | i < j = j-1 - | otherwise = j - fixExt i se (ReturnsInBlock mem ixfun) = - ReturnsInBlock mem (fixExtIxFun i (primExpFromSubExp int32 se) ixfun) - -fixExtIxFun :: Int -> PrimExp VName -> ExtIxFun -> ExtIxFun -fixExtIxFun i e = fmap $ replaceInPrimExp update - where update (Ext j) t | j > i = LeafExp (Ext $ j - 1) t - | j == i = fmap Free e - | otherwise = LeafExp (Ext j) t - update (Free x) t = LeafExp (Free x) t - -leafExp :: Int -> PrimExp (Ext a) -leafExp i = LeafExp (Ext i) int32 - -existentialiseIxFun :: [VName] -> IxFun -> ExtIxFun -existentialiseIxFun ctx = IxFun.substituteInIxFun ctx' . fmap (fmap Free) - where ctx' = M.map leafExp $ M.fromList $ zip (map Free ctx) [0..] - -instance PP.Pretty MemReturn where - ppr (ReturnsInBlock v ixfun) = - PP.parens $ PP.text (pretty v) <> PP.text "->" <> PP.ppr ixfun - ppr (ReturnsNewBlock space i ixfun) = - PP.text ("?" ++ show i) <> PP.ppr space <> PP.text "->" <> PP.ppr ixfun - -instance FreeIn MemReturn where - freeIn' (ReturnsInBlock v ixfun) = freeIn' v <> freeIn' ixfun - freeIn' _ = mempty - -instance Engine.Simplifiable MemReturn where - simplify (ReturnsNewBlock space i ixfun) = - ReturnsNewBlock space i <$> simplifyExtIxFun ixfun - simplify (ReturnsInBlock v ixfun) = - ReturnsInBlock <$> Engine.simplify v <*> simplifyExtIxFun ixfun - - -instance Engine.Simplifiable MemBind where - simplify (ArrayIn mem ixfun) = - ArrayIn <$> Engine.simplify mem <*> simplifyIxFun ixfun - -instance Engine.Simplifiable [FunReturns] where - simplify = mapM Engine.simplify - --- | The memory return of an expression. An array is annotated with --- @Maybe MemReturn@, which can be interpreted as the expression --- either dictating exactly where the array is located when it is --- returned (if 'Just'), or able to put it whereever the binding --- prefers (if 'Nothing'). --- --- This is necessary to capture the difference between an expression --- that is just an array-typed variable, in which the array being --- "returned" is located where it already is, and a @copy@ expression, --- whose entire purpose is to store an existing array in some --- arbitrary location. This is a consequence of the design decision --- never to have implicit memory copies. -type ExpReturns = MemInfo ExtSize NoUniqueness (Maybe MemReturn) - --- | The return of a body, which must always indicate where --- returned arrays are located. -type BodyReturns = MemInfo ExtSize NoUniqueness MemReturn - --- | The memory return of a function, which must always indicate where --- returned arrays are located. -type FunReturns = MemInfo ExtSize Uniqueness MemReturn - -maybeReturns :: MemInfo d u r -> MemInfo d u (Maybe r) -maybeReturns (MemArray bt shape u ret) = - MemArray bt shape u $ Just ret -maybeReturns (MemPrim bt) = - MemPrim bt -maybeReturns (MemMem space) = - MemMem space - -noUniquenessReturns :: MemInfo d u r -> MemInfo d NoUniqueness r -noUniquenessReturns (MemArray bt shape _ r) = - MemArray bt shape NoUniqueness r -noUniquenessReturns (MemPrim bt) = - MemPrim bt -noUniquenessReturns (MemMem space) = - MemMem space - -funReturnsToExpReturns :: FunReturns -> ExpReturns -funReturnsToExpReturns = noUniquenessReturns . maybeReturns - -bodyReturnsToExpReturns :: BodyReturns -> ExpReturns -bodyReturnsToExpReturns = noUniquenessReturns . maybeReturns - -matchFunctionReturnType :: Mem lore => - [FunReturns] -> Result -> TC.TypeM lore () -matchFunctionReturnType rettype result = do - scope <- askScope - result_ts <- runReaderT (mapM subExpMemInfo result) $ removeScopeAliases scope - matchReturnType rettype result result_ts - mapM_ checkResultSubExp result - where checkResultSubExp Constant{} = - return () - checkResultSubExp (Var v) = do - attr <- varMemInfo v - case attr of - MemPrim _ -> return () - MemMem{} -> return () - MemArray _ _ _ (ArrayIn _ ixfun) - | IxFun.isLinear ixfun -> - return () - | otherwise -> - TC.bad $ TC.TypeError $ - "Array " ++ pretty v ++ - " returned by function, but has nontrivial index function " ++ - pretty ixfun - -matchBranchReturnType :: Mem lore => - [BodyReturns] - -> Body (Aliases lore) - -> TC.TypeM lore () -matchBranchReturnType rettype (Body _ stms res) = do - scope <- askScope - ts <- runReaderT (mapM subExpMemInfo res) $ removeScopeAliases (scope <> scopeOf stms) - matchReturnType rettype res ts - --- | Helper function for index function unification. --- --- The first return value maps a VName (wrapped in 'Free') to its Int --- (wrapped in 'Ext'). In case of duplicates, it is mapped to the --- *first* Int that occurs. --- --- The second return value maps each Int (wrapped in an 'Ext') to a --- 'LeafExp' 'Ext' with the Int at which its associated VName first --- occurs. -getExtMaps :: [(VName,Int)] -> (M.Map (Ext VName) (PrimExp (Ext VName)), - M.Map (Ext VName) (PrimExp (Ext VName))) -getExtMaps ctx_lst_ids = - (M.map leafExp $ M.mapKeys Free $ M.fromListWith (flip const) ctx_lst_ids, - M.fromList $ - mapMaybe (traverse (fmap (\i -> LeafExp (Ext i) int32) . - (`lookup` ctx_lst_ids)) . - uncurry (flip (,)) . fmap Ext) ctx_lst_ids) - -matchReturnType :: PP.Pretty u => - [MemInfo ExtSize u MemReturn] - -> [SubExp] - -> [MemInfo SubExp NoUniqueness MemBind] - -> TC.TypeM lore () -matchReturnType rettype res ts = do - let (ctx_ts, val_ts) = splitFromEnd (length rettype) ts - (ctx_res, _val_res) = splitFromEnd (length rettype) res - - existentialiseIxFun0 :: IxFun -> ExtIxFun - existentialiseIxFun0 = fmap $ fmap Free - - fetchCtx i = case maybeNth i $ zip ctx_res ctx_ts of - Nothing -> throwError $ "Cannot find context variable " ++ - show i ++ " in context results: " ++ pretty ctx_res - Just (se, t) -> return (se, t) - - checkReturn (MemPrim x) (MemPrim y) - | x == y = return () - checkReturn (MemMem x) (MemMem y) - | x == y = return () - checkReturn (MemArray x_pt x_shape _ x_ret) - (MemArray y_pt y_shape _ y_ret) - | x_pt == y_pt, shapeRank x_shape == shapeRank y_shape = do - zipWithM_ checkDim (shapeDims x_shape) (shapeDims y_shape) - checkMemReturn x_ret y_ret - checkReturn x y = - throwError $ unwords ["Expected ", pretty x, " but got ", pretty y] - - checkDim (Free x) y - | x == y = return () - | otherwise = throwError $ unwords ["Expected dim", pretty x, - "but got", pretty y] - checkDim (Ext i) y = do - (x, _) <- fetchCtx i - unless (x == y) $ - throwError $ unwords ["Expected ext dim", pretty i, "=>", pretty x, - "but got", pretty y] - - extsInMemInfo :: MemInfo ExtSize u MemReturn -> S.Set Int - extsInMemInfo (MemArray _ shp _ ret) = - extInShape shp <> extInMemReturn ret - extsInMemInfo _ = S.empty - - checkMemReturn (ReturnsInBlock x_mem x_ixfun) (ArrayIn y_mem y_ixfun) - | x_mem == y_mem = - unless (IxFun.closeEnough x_ixfun $ existentialiseIxFun0 y_ixfun) $ - throwError $ unwords ["Index function unification failed (ReturnsInBlock)", - "\nixfun of body result: ", pretty y_ixfun, - "\nixfun of return type: ", pretty x_ixfun, - "\nand context elements: ", pretty ctx_res] - checkMemReturn (ReturnsNewBlock x_space x_ext x_ixfun) - (ArrayIn y_mem y_ixfun) = do - (x_mem, x_mem_type) <- fetchCtx x_ext - unless (IxFun.closeEnough x_ixfun $ existentialiseIxFun0 y_ixfun) $ - throwError $ unwords ["Index function unification failed (ReturnsNewBlock)", - "\nixfun of body result: ", pretty y_ixfun, - "\nixfun of return type: ", pretty x_ixfun, - "\nand context elements: ", pretty ctx_res] - case x_mem_type of - MemMem y_space -> do - unless (x_mem == Var y_mem) $ - throwError $ unwords ["Expected memory", pretty x_ext, "=>", pretty x_mem, - "but got", pretty y_mem] - unless (x_space == y_space) $ - throwError $ unwords ["Expected memory", pretty y_mem, "in space", pretty x_space, - "but actually in space", pretty y_space] - t -> - throwError $ unwords ["Expected memory", pretty x_ext, "=>", pretty x_mem, - "but but has type", pretty t] - checkMemReturn x y = - throwError $ unwords ["Expected array in", pretty x, - "but array returned in", pretty y] - - bad :: String -> TC.TypeM lore a - bad s = TC.bad $ TC.TypeError $ - unlines [ "Return type" - , " " ++ prettyTuple rettype - , "cannot match returns of results" - , " " ++ prettyTuple ts - , s - ] - - unless (length (S.unions $ map extsInMemInfo rettype) == length ctx_res) $ - TC.bad $ TC.TypeError $ "Too many context parameters for the number of " ++ - "existentials in the return type! type:\n " ++ - prettyTuple rettype ++ - "\ncannot match context parameters:\n " ++ prettyTuple ctx_res - - - either bad return =<< runExceptT (zipWithM_ checkReturn rettype val_ts) - -matchPatternToExp :: (Mem lore) => - Pattern (Aliases lore) - -> Exp (Aliases lore) - -> TC.TypeM lore () -matchPatternToExp pat e = do - scope <- asksScope removeScopeAliases - rt <- runReaderT (expReturns $ removeExpAliases e) scope - - let (ctxs, vals) = bodyReturnsFromPattern $ removePatternAliases pat - (ctx_ids, _ctx_ts) = unzip ctxs - (_val_ids, val_ts) = unzip vals - (ctx_map_ids, ctx_map_exts) = - getExtMaps $ zip ctx_ids [0..length ctx_ids - 1] - - let rt_exts = foldMap extInExpReturns rt - - unless (length val_ts == length rt && - and (zipWith (matches ctx_map_ids ctx_map_exts) val_ts rt) && - M.keysSet ctx_map_exts `S.isSubsetOf` S.map Ext rt_exts) $ - TC.bad $ TC.TypeError $ "Expression type:\n " ++ prettyTuple rt ++ - "\ncannot match pattern type:\n " ++ prettyTuple val_ts ++ - "\nwith context elements: " ++ pretty ctx_ids - where matches _ _ (MemPrim x) (MemPrim y) = x == y - matches _ _ (MemMem x_space) (MemMem y_space) = - x_space == y_space - matches ctxids ctxexts (MemArray x_pt x_shape _ x_ret) (MemArray y_pt y_shape _ y_ret) = - x_pt == y_pt && x_shape == y_shape && - case (x_ret, y_ret) of - (ReturnsInBlock x_mem x_ixfun, Just (ReturnsInBlock y_mem y_ixfun)) -> - let x_ixfun' = IxFun.substituteInIxFun ctxids x_ixfun - y_ixfun' = IxFun.substituteInIxFun ctxexts y_ixfun - in x_mem == y_mem && x_ixfun' == y_ixfun' - (ReturnsInBlock _ x_ixfun, - Just (ReturnsNewBlock _ _ y_ixfun)) -> - let x_ixfun' = IxFun.substituteInIxFun ctxids x_ixfun - y_ixfun' = IxFun.substituteInIxFun ctxexts y_ixfun - in x_ixfun' == y_ixfun' - (ReturnsNewBlock x_space x_i x_ixfun, - Just (ReturnsNewBlock y_space y_i y_ixfun)) -> - let x_ixfun' = IxFun.substituteInIxFun ctxids x_ixfun - y_ixfun' = IxFun.substituteInIxFun ctxexts y_ixfun - in x_space == y_space && x_i == y_i && IxFun.closeEnough x_ixfun' y_ixfun' - (_, Nothing) -> True - _ -> False - matches _ _ _ _ = False - - extInExpReturns :: ExpReturns -> S.Set Int - extInExpReturns (MemArray _ shape _ mem_return) = - extInShape shape <> maybe S.empty extInMemReturn mem_return - extInExpReturns _ = mempty - - -extInShape :: ShapeBase (Ext SubExp) -> S.Set Int -extInShape shape = S.fromList $ mapMaybe isExt $ shapeDims shape - -extInMemReturn :: MemReturn -> S.Set Int -extInMemReturn (ReturnsInBlock _ extixfn) = extInIxFn extixfn -extInMemReturn (ReturnsNewBlock _ i extixfn) = - S.singleton i <> extInIxFn extixfn - -extInIxFn :: ExtIxFun -> S.Set Int -extInIxFn ixfun = S.fromList $ concatMap (mapMaybe isExt . toList) ixfun - -varMemInfo :: Mem lore => - VName -> TC.TypeM lore (MemInfo SubExp NoUniqueness MemBind) -varMemInfo name = do - attr <- TC.lookupVar name - - case attr of - LetInfo (_, summary) -> return summary - FParamInfo summary -> return $ noUniquenessReturns summary - LParamInfo summary -> return summary - IndexInfo it -> return $ MemPrim $ IntType it - -nameInfoToMemInfo :: Mem lore => NameInfo lore -> MemBound NoUniqueness -nameInfoToMemInfo info = - case info of - FParamInfo summary -> noUniquenessReturns summary - LParamInfo summary -> summary - LetInfo summary -> summary - IndexInfo it -> MemPrim $ IntType it - -lookupMemInfo :: (HasScope lore m, Mem lore) => - VName -> m (MemInfo SubExp NoUniqueness MemBind) -lookupMemInfo = fmap nameInfoToMemInfo . lookupInfo - -subExpMemInfo :: (HasScope lore m, Monad m, Mem lore) => - SubExp -> m (MemInfo SubExp NoUniqueness MemBind) -subExpMemInfo (Var v) = lookupMemInfo v -subExpMemInfo (Constant v) = return $ MemPrim $ primValueType v - -lookupArraySummary :: (Mem lore, HasScope lore m, Monad m) => - VName -> m (VName, IxFun.IxFun (PrimExp VName)) -lookupArraySummary name = do - summary <- lookupMemInfo name - case summary of - MemArray _ _ _ (ArrayIn mem ixfun) -> - return (mem, ixfun) - _ -> - error $ "Variable " ++ pretty name ++ " does not look like an array." - -checkMemInfo :: TC.Checkable lore => - VName -> MemInfo SubExp u MemBind - -> TC.TypeM lore () -checkMemInfo _ (MemPrim _) = return () -checkMemInfo _ (MemMem (ScalarSpace d _)) = mapM_ (TC.require [Prim int32]) d -checkMemInfo _ (MemMem _) = return () -checkMemInfo name (MemArray _ shape _ (ArrayIn v ixfun)) = do - t <- lookupType v - case t of - Mem{} -> - return () - _ -> - TC.bad $ TC.TypeError $ - "Variable " ++ pretty v ++ - " used as memory block, but is of type " ++ - pretty t ++ "." - - TC.context ("in index function " ++ pretty ixfun) $ do - traverse_ (TC.requirePrimExp int32) ixfun - let ixfun_rank = IxFun.rank ixfun - ident_rank = shapeRank shape - unless (ixfun_rank == ident_rank) $ - TC.bad $ TC.TypeError $ - "Arity of index function (" ++ pretty ixfun_rank ++ - ") does not match rank of array " ++ pretty name ++ - " (" ++ show ident_rank ++ ")" - -bodyReturnsFromPattern :: PatternT (MemBound NoUniqueness) - -> ([(VName,BodyReturns)], [(VName,BodyReturns)]) -bodyReturnsFromPattern pat = - (map asReturns $ patternContextElements pat, - map asReturns $ patternValueElements pat) - where ctx = patternContextElements pat - - ext (Var v) - | Just (i, _) <- find ((==v) . patElemName . snd) $ zip [0..] ctx = - Ext i - ext se = Free se - - asReturns pe = - (patElemName pe, - case patElemAttr pe of - MemPrim pt -> MemPrim pt - MemMem space -> MemMem space - MemArray pt shape u (ArrayIn mem ixfun) -> - MemArray pt (Shape $ map ext $ shapeDims shape) u $ - case find ((==mem) . patElemName . snd) $ zip [0..] ctx of - Just (i, PatElem _ (MemMem space)) -> - ReturnsNewBlock space i $ - existentialiseIxFun (map patElemName ctx) ixfun - _ -> ReturnsInBlock mem $ existentialiseIxFun [] ixfun - ) - -instance (PP.Pretty u, PP.Pretty r) => PrettyAnnot (PatElemT (MemInfo SubExp u r)) where - ppAnnot = bindeeAnnot patElemName patElemAttr - -instance (PP.Pretty u, PP.Pretty r) => PrettyAnnot (Param (MemInfo SubExp u r)) where - ppAnnot = bindeeAnnot paramName paramAttr - -bindeeAnnot :: (PP.Pretty u, PP.Pretty r) => - (a -> VName) -> (a -> MemInfo SubExp u r) - -> a -> Maybe PP.Doc -bindeeAnnot bindeeName bindeeLore bindee = - case bindeeLore bindee of - attr@MemArray{} -> - Just $ - PP.text "-- " <> - PP.oneLine (PP.ppr (bindeeName bindee) <> - PP.text " : " <> - PP.ppr attr) - MemMem {} -> - Nothing - MemPrim _ -> - Nothing - -extReturns :: [ExtType] -> [ExpReturns] -extReturns ts = - evalState (mapM addAttr ts) 0 - where addAttr (Prim bt) = - return $ MemPrim bt - addAttr (Mem space) = - return $ MemMem space - addAttr t@(Array bt shape u) - | existential t = do - i <- get <* modify (+1) - return $ MemArray bt shape u $ Just $ - ReturnsNewBlock DefaultSpace i $ - IxFun.iota $ map convert $ shapeDims shape - | otherwise = - return $ MemArray bt shape u Nothing - convert (Ext i) = LeafExp (Ext i) int32 - convert (Free v) = Free <$> primExpFromSubExp int32 v - -arrayVarReturns :: (HasScope lore m, Monad m, Mem lore) => - VName - -> m (PrimType, Shape, VName, IxFun.IxFun (PrimExp VName)) -arrayVarReturns v = do - summary <- lookupMemInfo v - case summary of - MemArray et shape _ (ArrayIn mem ixfun) -> - return (et, Shape $ shapeDims shape, mem, ixfun) - _ -> - error $ "arrayVarReturns: " ++ pretty v ++ " is not an array." - -varReturns :: (HasScope lore m, Monad m, Mem lore) => - VName -> m ExpReturns -varReturns v = do - summary <- lookupMemInfo v - case summary of - MemPrim bt -> - return $ MemPrim bt - MemArray et shape _ (ArrayIn mem ixfun) -> - return $ MemArray et (fmap Free shape) NoUniqueness $ - Just $ ReturnsInBlock mem $ existentialiseIxFun [] ixfun - MemMem space -> - return $ MemMem space - --- | The return information of an expression. This can be seen as the --- "return type with memory annotations" of the expression. -expReturns :: (Monad m, HasScope lore m, - Mem lore) => - Exp lore -> m [ExpReturns] - -expReturns (BasicOp (SubExp (Var v))) = - pure <$> varReturns v - -expReturns (BasicOp (Opaque (Var v))) = - pure <$> varReturns v - -expReturns (BasicOp (Repeat outer_shapes inner_shape v)) = do - t <- repeatDims outer_shapes inner_shape <$> lookupType v - (et, _, mem, ixfun) <- arrayVarReturns v - let outer_shapes' = map (map (primExpFromSubExp int32) . shapeDims) outer_shapes - inner_shape' = map (primExpFromSubExp int32) $ shapeDims inner_shape - return [MemArray et (Shape $ map Free $ arrayDims t) NoUniqueness $ - Just $ ReturnsInBlock mem $ existentialiseIxFun [] $ - IxFun.repeat ixfun outer_shapes' inner_shape'] - -expReturns (BasicOp (Reshape newshape v)) = do - (et, _, mem, ixfun) <- arrayVarReturns v - return [MemArray et (Shape $ map (Free . newDim) newshape) NoUniqueness $ - Just $ ReturnsInBlock mem $ existentialiseIxFun [] $ - IxFun.reshape ixfun $ map (fmap $ primExpFromSubExp int32) newshape] - -expReturns (BasicOp (Rearrange perm v)) = do - (et, Shape dims, mem, ixfun) <- arrayVarReturns v - let ixfun' = IxFun.permute ixfun perm - dims' = rearrangeShape perm dims - return [MemArray et (Shape $ map Free dims') NoUniqueness $ - Just $ ReturnsInBlock mem $ existentialiseIxFun [] ixfun'] - -expReturns (BasicOp (Rotate offsets v)) = do - (et, Shape dims, mem, ixfun) <- arrayVarReturns v - let offsets' = map (primExpFromSubExp int32) offsets - ixfun' = IxFun.rotate ixfun offsets' - return [MemArray et (Shape $ map Free dims) NoUniqueness $ - Just $ ReturnsInBlock mem $ existentialiseIxFun [] ixfun'] - -expReturns (BasicOp (Index v slice)) = do - info <- sliceInfo v slice - case info of - MemArray et shape u (ArrayIn mem ixfun) -> - return [MemArray et (fmap Free shape) u $ - Just $ ReturnsInBlock mem $ existentialiseIxFun [] ixfun] - MemPrim pt -> return [MemPrim pt] - MemMem space -> return [MemMem space] - -expReturns (BasicOp (Update v _ _)) = - pure <$> varReturns v - -expReturns (BasicOp op) = - extReturns . staticShapes <$> primOpType op - -expReturns e@(DoLoop ctx val _ _) = do - t <- expExtType e - zipWithM typeWithAttr t $ map fst val - where typeWithAttr t p = - case (t, paramAttr p) of - (Array bt shape u, MemArray _ _ _ (ArrayIn mem ixfun)) - | Just (i, mem_p) <- isMergeVar mem, - Mem space <- paramType mem_p -> - return $ MemArray bt shape u $ Just $ ReturnsNewBlock space i ixfun' - | otherwise -> - return (MemArray bt shape u $ - Just $ ReturnsInBlock mem ixfun') - where ixfun' = existentialiseIxFun (map paramName mergevars) ixfun - (Array{}, _) -> - error "expReturns: Array return type but not array merge variable." - (Prim bt, _) -> - return $ MemPrim bt - (Mem{}, _) -> - error "expReturns: loop returns memory block explicitly." - isMergeVar v = find ((==v) . paramName . snd) $ zip [0..] mergevars - mergevars = map fst $ ctx ++ val - -expReturns (Apply _ _ ret _) = - return $ map funReturnsToExpReturns ret - -expReturns (If _ _ _ (IfAttr ret _)) = - return $ map bodyReturnsToExpReturns ret - -expReturns (Op op) = - opReturns op - -sliceInfo :: (Monad m, HasScope lore m, Mem lore) => - VName - -> Slice SubExp -> m (MemInfo SubExp NoUniqueness MemBind) -sliceInfo v slice = do - (et, _, mem, ixfun) <- arrayVarReturns v - case sliceDims slice of - [] -> return $ MemPrim et - dims -> - return $ MemArray et (Shape dims) NoUniqueness $ - ArrayIn mem $ IxFun.slice ixfun - (map (fmap (primExpFromSubExp int32)) slice) - -class TypedOp (Op lore) => OpReturns lore where - opReturns :: (Monad m, HasScope lore m) => - Op lore -> m [ExpReturns] - opReturns op = extReturns <$> opType op - -applyFunReturns :: Typed attr => - [FunReturns] - -> [Param attr] - -> [(SubExp,Type)] - -> Maybe [FunReturns] -applyFunReturns rets params args - | Just _ <- applyRetType rettype params args = - Just $ map correctDims rets - | otherwise = - Nothing - where rettype = map declExtTypeOf rets - parammap :: M.Map VName (SubExp, Type) - parammap = M.fromList $ - zip (map paramName params) args - - substSubExp (Var v) - | Just (se,_) <- M.lookup v parammap = se - substSubExp se = se - - correctDims (MemPrim t) = - MemPrim t - correctDims (MemMem space) = - MemMem space - correctDims (MemArray et shape u memsummary) = - MemArray et (correctShape shape) u $ - correctSummary memsummary - - correctShape = Shape . map correctDim . shapeDims - correctDim (Ext i) = Ext i - correctDim (Free se) = Free $ substSubExp se - - correctSummary (ReturnsNewBlock space i ixfun) = - ReturnsNewBlock space i ixfun - correctSummary (ReturnsInBlock mem ixfun) = - -- FIXME: we should also do a replacement in ixfun here. - ReturnsInBlock mem' ixfun - where mem' = case M.lookup mem parammap of - Just (Var v, _) -> v - _ -> mem diff --git a/src/Futhark/Representation/Mem/IxFun.hs b/src/Futhark/Representation/Mem/IxFun.hs deleted file mode 100644 --- a/src/Futhark/Representation/Mem/IxFun.hs +++ /dev/null @@ -1,841 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} --- | This module contains a representation for the index function based on --- linear-memory accessor descriptors; see Zhu, Hoeflinger and David work. -module Futhark.Representation.Mem.IxFun - ( IxFun(..) - , index - , iota - , offsetIndex - , permute - , rotate - , reshape - , slice - , rebase - , repeat - , shape - , rank - , linearWithOffset - , rearrangeWithOffset - , isDirect - , isLinear - , substituteInIxFun - , leastGeneralGeneralization - , closeEnough - ) - where - -import Prelude hiding (mod, repeat) -import Data.List (sort, sortBy, zip4, zip5, zipWith5) -import qualified Data.List.NonEmpty as NE -import Data.List.NonEmpty (NonEmpty(..)) -import Data.Function (on) -import Data.Maybe (isJust) -import Control.Monad.Identity -import Control.Monad.Writer -import qualified Data.Map.Strict as M - -import Futhark.Analysis.PrimExp (PrimExp(..)) -import Futhark.Representation.AST.Syntax.Core (Ext(..)) -import Futhark.Transform.Substitute -import Futhark.Transform.Rename -import Futhark.Representation.AST.Syntax - (ShapeChange, DimChange(..), DimIndex(..), Slice, unitSlice, dimFix) -import Futhark.Representation.AST.Attributes -import Futhark.Util.IntegralExp -import Futhark.Util.Pretty -import Futhark.Analysis.PrimExp.Convert (substituteInPrimExp) -import qualified Futhark.Analysis.PrimExp.Generalize as PEG - --- | LMAD's representation consists of a general offset and for each dimension a --- stride, rotate factor, number of elements (or shape), permutation, and --- monotonicity. Note that the permutation is not strictly necessary in that the --- permutation can be performed directly on LMAD dimensions, but then it is --- difficult to extract the permutation back from an LMAD. --- --- LMAD algebra is closed under composition w.r.t. operators such as permute, --- repeat, index and slice. However, other operations, such as reshape, cannot --- always be represented inside the LMAD algebra. --- --- It follows that the general representation of an index function is a list of --- LMADS, in which each following LMAD in the list implicitly corresponds to an --- irregular reshaping operation. --- --- However, we expect that the common case is when the index function is one --- LMAD -- we call this the 'nice' representation. --- --- Finally, the list of LMADs is kept in an @IxFun@ together with the shape of --- the original array, and a bit to indicate whether the index function is --- contiguous, i.e., if we instantiate all the points of the current index --- function, do we get a contiguous memory interval? --- --- By definition, the LMAD denotes the set of points (simplified): --- --- \{ o + \Sigma_{j=0}^{k} ((i_j+r_j) `mod` n_j)*s_j, --- \forall i_j such that 0<=i_j Pretty (LMAD num) where - ppr (LMAD offset dims) = - braces $ semisep [ text "offset: " <> oneLine (ppr offset) - , text "strides: " <> p ldStride - , text "rotates: " <> p ldRotate - , text "shape: " <> p ldShape - , text "permutation: " <> p ldPerm - , text "monotonicity: " <> p ldMon - ] - where p f = oneLine $ brackets $ commasep $ map (ppr . f) dims - -instance Pretty num => Pretty (IxFun num) where - ppr (IxFun lmads oshp cg) = - braces $ semisep [ text "base: " <> brackets (commasep $ map ppr oshp) - , text "contiguous: " <> text (show cg) - , text "LMADs: " <> brackets (commasep $ NE.toList $ NE.map ppr lmads) - ] - - -instance Substitute num => Substitute (LMAD num) where - substituteNames substs = fmap $ substituteNames substs - -instance Substitute num => Substitute (IxFun num) where - substituteNames substs = fmap $ substituteNames substs - -instance Substitute num => Rename (LMAD num) where - rename = substituteRename - -instance Substitute num => Rename (IxFun num) where - rename = substituteRename - - -instance FreeIn num => FreeIn (LMAD num) where - freeIn' = foldMap freeIn' - -instance FreeIn num => FreeIn (IxFun num) where - freeIn' = foldMap freeIn' - -instance Functor LMAD where - fmap f = runIdentity . traverse (return . f) - -instance Functor IxFun where - fmap f = runIdentity . traverse (return . f) - - -instance Foldable LMAD where - foldMap f = execWriter . traverse (tell . f) - -instance Foldable IxFun where - foldMap f = execWriter . traverse (tell . f) - - -instance Traversable LMAD where - traverse f (LMAD offset dims) = - LMAD <$> f offset <*> traverse f' dims - where f' (LMADDim s r n p m) = - LMADDim <$> f s <*> f r <*> f n <*> pure p <*> pure m - -instance Traversable IxFun where - traverse f (IxFun lmads oshp cg) = - IxFun <$> traverse (traverse f) lmads <*> traverse f oshp <*> pure cg - -(++@) :: [a] -> NonEmpty a -> NonEmpty a -es ++@ (ne :| nes) = case es of - e : es' -> e :| es' ++ [ne] ++ nes - [] -> ne :| nes - -(@++@) :: NonEmpty a -> NonEmpty a -> NonEmpty a -(x :| xs) @++@ (y :| ys) = x :| xs ++ [y] ++ ys - -invertMonotonicity :: Monotonicity -> Monotonicity -invertMonotonicity Inc = Dec -invertMonotonicity Dec = Inc -invertMonotonicity Unknown = Unknown - -lmadPermutation :: LMAD num -> Permutation -lmadPermutation = map ldPerm . lmadDims - -setLMADPermutation :: Permutation -> LMAD num -> LMAD num -setLMADPermutation perm lmad = - lmad { lmadDims = zipWith (\dim p -> dim { ldPerm = p }) (lmadDims lmad) perm } - -setLMADShape :: Shape num -> LMAD num -> LMAD num -setLMADShape shp lmad = lmad { lmadDims = zipWith (\dim s -> dim { ldShape = s }) (lmadDims lmad) shp } - --- | Substitute a name with a PrimExp in an LMAD. -substituteInLMAD :: Ord a => M.Map a (PrimExp a) -> LMAD (PrimExp a) - -> LMAD (PrimExp a) -substituteInLMAD tab (LMAD offset dims) = - let offset' = substituteInPrimExp tab offset - dims' = map (\(LMADDim s r n p m) -> - LMADDim - (substituteInPrimExp tab s) - (substituteInPrimExp tab r) - (substituteInPrimExp tab n) - p m) - dims - in LMAD offset' dims' - --- | Substitute a name with a PrimExp in an index function. -substituteInIxFun :: (Ord a) => M.Map a (PrimExp a) -> IxFun (PrimExp a) - -> IxFun (PrimExp a) -substituteInIxFun tab (IxFun lmads oshp cg) = - IxFun (NE.map (substituteInLMAD tab) lmads) - (map (substituteInPrimExp tab) oshp) - cg - --- | Is this is a row-major array? -isDirect :: (Eq num, IntegralExp num) => IxFun num -> Bool -isDirect ixfun@(IxFun (LMAD offset dims :| []) oshp True) = - let strides_expected = reverse $ scanl (*) 1 (reverse (tail oshp)) - in hasContiguousPerm ixfun && - length oshp == length dims && - offset == 0 && - all (\(LMADDim s r n p _, m, d, se) -> - s == se && r == 0 && n == d && p == m) - (zip4 dims [0..length dims - 1] oshp strides_expected) -isDirect _ = False - --- | Does the index function have an ascending permutation? -hasContiguousPerm :: IxFun num -> Bool -hasContiguousPerm (IxFun (lmad :| []) _ _) = - let perm = lmadPermutation lmad - in perm == sort perm -hasContiguousPerm _ = False - --- | Shape of an index function. -shape :: (Eq num, IntegralExp num) => IxFun num -> Shape num -shape (IxFun (lmad :| _) _ _) = lmadShape lmad - --- | Shape of an LMAD. -lmadShape :: (Eq num, IntegralExp num) => LMAD num -> Shape num -lmadShape lmad = permuteInv (lmadPermutation lmad) $ lmadShapeBase lmad - --- | Shape of an LMAD, ignoring permutations. -lmadShapeBase :: (Eq num, IntegralExp num) => LMAD num -> Shape num -lmadShapeBase = map ldShape . lmadDims - --- | Compute the flat memory index for a complete set `inds` of array indices --- and a certain element size `elem_size`. -index :: (IntegralExp num, Eq num) => - IxFun num -> Indices num -> num -index = indexFromLMADs . ixfunLMADs - where indexFromLMADs :: (IntegralExp num, Eq num) => - NonEmpty (LMAD num) -> Indices num -> num - indexFromLMADs (lmad :| []) inds = indexLMAD lmad inds - indexFromLMADs (lmad1 :| lmad2 : lmads) inds = - let i_flat = indexLMAD lmad1 inds - new_inds = unflattenIndex (permuteFwd (lmadPermutation lmad2) $ lmadShapeBase lmad2) i_flat - in indexFromLMADs (lmad2 :| lmads) new_inds - - -- | Compute the flat index of an LMAD. - indexLMAD :: (IntegralExp num, Eq num) => - LMAD num -> Indices num -> num - indexLMAD lmad@(LMAD off dims) inds = - let prod = sum $ zipWith flatOneDim - (map (\(LMADDim s r n _ _) -> (s, r, n)) dims) - (permuteInv (lmadPermutation lmad) inds) - in off + prod - --- | iota. -iota :: IntegralExp num => Shape num -> IxFun num -iota ns = - let rs = replicate (length ns) 0 - in IxFun (makeRotIota Inc 0 (zip rs ns) :| []) ns True - --- | Permute dimensions. -permute :: IntegralExp num => - IxFun num -> Permutation -> IxFun num -permute (IxFun (lmad :| lmads) oshp cg) perm_new = - let perm_cur = lmadPermutation lmad - perm = map (perm_cur !!) perm_new - in IxFun (setLMADPermutation perm lmad :| lmads) oshp cg - --- | Repeat dimensions. -repeat :: (Eq num, IntegralExp num) => - IxFun num -> [Shape num] -> Shape num -> IxFun num -repeat (IxFun (lmad@(LMAD off dims) :| lmads) oshp _) shps shp = - let perm = lmadPermutation lmad - -- inverse permute the shapes and update the permutation - lens = map (\s -> 1 + length s) shps - (shps', lens') = unzip $ permuteInv perm $ zip shps lens - scn = drop 1 $ scanl (+) 0 lens' - perm' = concatMap (\(p, l) -> map (\i-> (scn !! p) - l + i) [0..l-1]) - $ zip perm lens - tmp = length perm' - perm'' = perm' ++ [tmp..tmp-1+length shp] - - dims' = concatMap (\(shp_k, srnp) -> - map fakeDim shp_k ++ [srnp] - ) $ zip shps' dims - lmad' = setLMADPermutation perm'' $ LMAD off (dims' ++ map fakeDim shp) - in IxFun (lmad' :| lmads) oshp False -- XXX: Can we be less conservative? - where fakeDim x = LMADDim 0 0 x 0 Unknown - --- | Rotate an index function. -rotate :: (Eq num, IntegralExp num) => - IxFun num -> Indices num -> IxFun num -rotate (IxFun (lmad@(LMAD off dims) :| lmads) oshp cg) offs = - let dims' = zipWith (\(LMADDim s r n p f) o -> - if s == 0 then LMADDim 0 0 n p Unknown - else LMADDim s (r + o) n p f - ) dims (permuteInv (lmadPermutation lmad) offs) - in IxFun (LMAD off dims' :| lmads) oshp cg - --- | Handle the case where a slice can stay within a single LMAD. -sliceOneLMAD :: (Eq num, IntegralExp num) => - IxFun num -> Slice num -> Maybe (IxFun num) -sliceOneLMAD (IxFun (lmad@(LMAD _ ldims) :| lmads) oshp cg) is = do - let perm = lmadPermutation lmad - is' = permuteInv perm is - cg' = cg && slicePreservesContiguous lmad is' - guard $ harmlessRotation lmad is' - let lmad' = foldl sliceOne (LMAD (lmadOffset lmad) []) $ zip is' ldims - -- need to remove the fixed dims from the permutation - perm' = updatePerm perm $ map fst $ filter (isJust . dimFix . snd) $ - zip [0..length is' - 1] is' - - return $ IxFun (setLMADPermutation perm' lmad' :| lmads) oshp cg' - where updatePerm ps inds = foldl (\acc p -> acc ++ decrease p) [] ps - where decrease p = - let d = foldl (\n i -> if i == p then -1 - else if i > p - then n - else if n /= -1 then n + 1 - else n - ) 0 inds - in [p - d | d /= -1] - - harmlessRotation' :: (Eq num, IntegralExp num) => - LMADDim num -> DimIndex num -> Bool - harmlessRotation' _ (DimFix _) = True - harmlessRotation' (LMADDim 0 _ _ _ _) _ = True - harmlessRotation' (LMADDim _ 0 _ _ _) _ = True - harmlessRotation' (LMADDim _ _ n _ _) dslc - | dslc == DimSlice (n - 1) n (-1) || - dslc == unitSlice 0 n = True - harmlessRotation' _ _ = False - - harmlessRotation :: (Eq num, IntegralExp num) => - LMAD num -> Slice num -> Bool - harmlessRotation (LMAD _ dims) iss = - and $ zipWith harmlessRotation' dims iss - - -- XXX: TODO: what happens to r on a negative-stride slice; is there - -- such a case? - sliceOne :: (Eq num, IntegralExp num) => - LMAD num -> (DimIndex num, LMADDim num) -> LMAD num - sliceOne (LMAD off dims) (DimFix i, LMADDim s r n _ _) = - LMAD (off + flatOneDim (s, r, n) i) dims - sliceOne (LMAD off dims) (DimSlice _ ne _, LMADDim 0 _ _ p _) = - LMAD off (dims ++ [LMADDim 0 0 ne p Unknown]) - sliceOne (LMAD off dims) (dmind, dim@(LMADDim _ _ n _ _)) - | dmind == unitSlice 0 n = LMAD off (dims ++ [dim]) - sliceOne (LMAD off dims) (dmind, LMADDim s r n p m) - | dmind == DimSlice (n - 1) n (-1) = - let r' = if r == 0 then 0 else n - r - off' = off + flatOneDim (s, 0, n) (n - 1) - in LMAD off' (dims ++ [LMADDim (s * (-1)) r' n p (invertMonotonicity m)]) - sliceOne (LMAD off dims) (DimSlice b ne 0, LMADDim s r n p _) = - LMAD (off + flatOneDim (s, r, n) b) (dims ++ [LMADDim 0 0 ne p Unknown]) - sliceOne (LMAD off dims) (DimSlice bs ns ss, LMADDim s 0 _ p m) = - let m' = case sgn ss of - Just 1 -> m - Just (-1) -> invertMonotonicity m - _ -> Unknown - in LMAD (off + s * bs) (dims ++ [LMADDim (ss * s) 0 ns p m']) - sliceOne _ _ = error "slice: reached impossible case" - - slicePreservesContiguous :: (Eq num, IntegralExp num) => - LMAD num -> Slice num -> Bool - slicePreservesContiguous (LMAD _ dims) slc = - -- remove from the slice the LMAD dimensions that have stride 0. - -- If the LMAD was contiguous in mem, then these dims will not - -- influence the contiguousness of the result. - -- Also normalize the input slice, i.e., 0-stride and size-1 - -- slices are rewritten as DimFixed. - let (dims', slc') = unzip $ - filter ((/= 0) . ldStride . fst) $ - zip dims $ map normIndex slc - -- Check that: - -- 1. a clean split point exists between Fixed and Sliced dims - -- 2. the outermost sliced dim has +/- 1 stride AND is unrotated or full. - -- 3. the rest of inner sliced dims are full. - (_, success) = - foldl (\(found, res) (slcdim, LMADDim _ r n _ _) -> - case (slcdim, found) of - (DimFix{}, True ) -> (found, False) - (DimFix{}, False) -> (found, res) - (DimSlice _ ne ds, False) -> -- outermost sliced dim: +/-1 stride - let res' = (r == 0 || n == ne) && (ds == 1 || ds == -1) - in (True, res && res') - (DimSlice _ ne ds, True) -> -- inner sliced dim: needs to be full - let res' = (n == ne) && (ds == 1 || ds == -1) - in (found, res && res') - ) (False, True) $ zip slc' dims' - in success - - normIndex :: (Eq num, IntegralExp num) => - DimIndex num -> DimIndex num - normIndex (DimSlice b 1 _) = DimFix b - normIndex (DimSlice b _ 0) = DimFix b - normIndex d = d - --- | Slice an index function. -slice :: (Eq num, IntegralExp num) => - IxFun num -> Slice num -> IxFun num -slice _ [] = error "slice: empty slice" -slice ixfun@(IxFun (lmad@(LMAD _ _) :| lmads) oshp cg) dim_slices - -- Avoid identity slicing. - | dim_slices == map (unitSlice 0) (shape ixfun) = ixfun - | Just ixfun' <- sliceOneLMAD ixfun dim_slices = ixfun' - | otherwise = - case sliceOneLMAD (iota (lmadShape lmad)) dim_slices of - Just (IxFun (lmad' :| []) _ cg') -> - IxFun (lmad' :| lmad : lmads) oshp (cg && cg') - _ -> error "slice: reached impossible case" - --- | Handle the simple case where all reshape dimensions are coercions. -reshapeCoercion :: (Eq num, IntegralExp num) => - IxFun num -> ShapeChange num -> Maybe (IxFun num) -reshapeCoercion (IxFun (lmad@(LMAD off dims) :| lmads) _ cg) newshape = do - let perm = lmadPermutation lmad - (head_coercions, reshapes, tail_coercions) <- splitCoercions newshape - let hd_len = length head_coercions - num_coercions = hd_len + length tail_coercions - dims' = permuteFwd perm dims - mid_dims = take (length dims - num_coercions) $ drop hd_len dims' - num_rshps = length reshapes - guard (num_rshps == 0 || (num_rshps == 1 && length mid_dims == 1)) - let dims'' = map snd $ sortBy (compare `on` fst) $ - zipWith (\ld n -> (ldPerm ld, ld { ldShape = n })) - dims' (newDims newshape) - lmad' = LMAD off dims'' - return $ IxFun (lmad' :| lmads) (newDims newshape) cg - --- | Handle the case where a reshape operation can stay inside a single LMAD. --- --- There are four conditions that all must hold for the result of a reshape --- operation to remain in the one-LMAD domain: --- --- (1) the permutation of the underlying LMAD must leave unchanged --- the LMAD dimensions that were *not* reshape coercions. --- (2) the repetition of dimensions of the underlying LMAD must --- refer only to the coerced-dimensions of the reshape operation. --- (3) similarly, the rotated dimensions must refer only to --- dimensions that are coerced by the reshape operation. --- (4) finally, the underlying memory is contiguous (and monotonous). --- --- If any of these conditions do not hold, then the reshape operation will --- conservatively add a new LMAD to the list, leading to a representation that --- provides less opportunities for further analysis. -reshapeOneLMAD :: (Eq num, IntegralExp num) => - IxFun num -> ShapeChange num -> Maybe (IxFun num) -reshapeOneLMAD ixfun@(IxFun (lmad@(LMAD off dims) :| lmads) _ cg) newshape = do - let perm = lmadPermutation lmad - (head_coercions, reshapes, tail_coercions) <- splitCoercions newshape - let hd_len = length head_coercions - num_coercions = hd_len + length tail_coercions - dims_perm = permuteFwd perm dims - mid_dims = take (length dims - num_coercions) $ drop hd_len dims_perm - -- Ignore rotates, as we only care about not having rotates in the - -- dimensions that aren't coercions (@mid_dims@), which we check - -- separately. - mon = ixfunMonotonicityRots True ixfun - - guard $ - -- checking conditions (2) and (3) - all (\ (LMADDim s r _ _ _) -> s /= 0 && r == 0) mid_dims && - -- checking condition (1) - consecutive hd_len (map ldPerm mid_dims) && - -- checking condition (4) - hasContiguousPerm ixfun && cg && (mon == Inc || mon == Dec) - - -- make new permutation - let rsh_len = length reshapes - diff = length newshape - length dims - iota_shape = [0..length newshape-1] - perm' = map (\i -> let ind = if i < hd_len - then i else i - diff - in if (i >= hd_len) && (i < hd_len + rsh_len) - then i -- already checked mid_dims not affected - else let p = ldPerm (dims !! ind) - in if p < hd_len - then p - else p + diff - ) iota_shape - -- split the dimensions - (support_inds, repeat_inds) = - foldl (\(sup, rpt) (i, shpdim, ip) -> - case (i < hd_len, i >= hd_len + rsh_len, shpdim) of - (True, _, DimCoercion n) -> - case dims_perm !! i of - (LMADDim 0 _ _ _ _) -> ( sup, (ip, n) : rpt ) - (LMADDim _ r _ _ _) -> ( (ip, (r, n)) : sup, rpt ) - (_, True, DimCoercion n) -> - case dims_perm !! (i-diff) of - (LMADDim 0 _ _ _ _) -> ( sup, (ip, n) : rpt ) - (LMADDim _ r _ _ _) -> ( (ip, (r, n)) : sup, rpt ) - (False, False, _) -> - ( (ip, (0, newDim shpdim)) : sup, rpt ) - -- already checked that the reshaped - -- dims cannot be repeats or rotates - _ -> error "reshape: reached impossible case" - ) ([], []) $ reverse $ zip3 iota_shape newshape perm' - - (sup_inds, support) = unzip $ sortBy (compare `on` fst) support_inds - (rpt_inds, repeats) = unzip repeat_inds - LMAD off' dims_sup = makeRotIota mon off support - repeats' = map (\n -> LMADDim 0 0 n 0 Unknown) repeats - dims' = map snd $ sortBy (compare `on` fst) - $ zip sup_inds dims_sup ++ zip rpt_inds repeats' - lmad' = LMAD off' dims' - return $ IxFun (setLMADPermutation perm' lmad' :| lmads) (newDims newshape) cg - where consecutive _ [] = True - consecutive i [p]= i == p - consecutive i ps = and $ zipWith (==) ps [i, i+1..] - -splitCoercions :: (Eq num, IntegralExp num) => - ShapeChange num -> Maybe (ShapeChange num, ShapeChange num, ShapeChange num) -splitCoercions newshape' = do - let (head_coercions, newshape'') = span isCoercion newshape' - (reshapes, tail_coercions) = break isCoercion newshape'' - guard (all isCoercion tail_coercions) - return (head_coercions, reshapes, tail_coercions) - where isCoercion DimCoercion{} = True - isCoercion _ = False - --- | Reshape an index function. -reshape :: (Eq num, IntegralExp num) => - IxFun num -> ShapeChange num -> IxFun num -reshape ixfun new_shape - | Just ixfun' <- reshapeCoercion ixfun new_shape = ixfun' - | Just ixfun' <- reshapeOneLMAD ixfun new_shape = ixfun' -reshape (IxFun (lmad0 :| lmad0s) oshp cg) new_shape = - case iota (newDims new_shape) of - IxFun (lmad :| []) _ _ -> IxFun (lmad :| lmad0 : lmad0s) oshp cg - _ -> error "reshape: reached impossible case" - -rank :: IntegralExp num => - IxFun num -> Int -rank (IxFun (LMAD _ sss :| _) _ _) = length sss - --- | Handle the case where a rebase operation can stay within m + n - 1 LMADs, --- where m is the number of LMADs in the index function, and n is the number of --- LMADs in the new base. If both index function have only on LMAD, this means --- that we stay within the single-LMAD domain. --- --- We can often stay in that domain if the original ixfun is essentially a --- slice, e.g. `x[i, (k1,m,s1), (k2,n,s2)] = orig`. --- --- XXX: TODO: handle repetitions in both lmads. --- --- How to handle repeated dimensions in the original? --- --- (a) Shave them off of the last lmad of original --- (b) Compose the result from (a) with the first --- lmad of the new base --- (c) apply a repeat operation on the result of (b). --- --- However, I strongly suspect that for in-place update what we need is actually --- the INVERSE of the rebase function, i.e., given an index function new-base --- and another one orig, compute the index function ixfun0 such that: --- --- new-base == rebase ixfun0 ixfun, or equivalently: --- new-base == ixfun o ixfun0 --- --- because then I can go bottom up and compose with ixfun0 all the index --- functions corresponding to the memory block associated with ixfun. -rebaseNice :: (Eq num, IntegralExp num) => - IxFun num -> IxFun num -> Maybe (IxFun num) -rebaseNice - new_base@(IxFun (lmad_base :| lmads_base) _ cg_base) - ixfun@(IxFun lmads shp cg) = do - let (lmad_full :| lmads') = NE.reverse lmads - ((outer_shapes, inner_shape), lmad) = shaveoffRepeats lmad_full - dims = lmadDims lmad - perm = lmadPermutation lmad - perm_base = lmadPermutation lmad_base - - guard $ - -- Core rebase condition. - base ixfun == shape new_base - -- Conservative safety conditions: ixfun is contiguous and has known - -- monotonicity for all dimensions. - && cg && all ((/= Unknown) . ldMon) dims - -- XXX: We should be able to handle some basic cases where both index - -- functions have non-trivial permutations. - && (hasContiguousPerm ixfun || hasContiguousPerm new_base) - -- We need the permutations to be of the same size if we want to compose - -- them. They don't have to be of the same size if the ixfun has a trivial - -- permutation. Supporting this latter case allows us to rebase when ixfun - -- has been created by slicing with fixed dimensions. - && (length perm == length perm_base || hasContiguousPerm ixfun) - -- To not have to worry about ixfun having non-1 strides, we also check that - -- it is a row-major array (modulo permutation, which is handled - -- separately). Accept a non-full innermost dimension. XXX: Maybe this can - -- be less conservative? - && and (zipWith3 (\sn ld inner -> sn == ldShape ld || (inner && ldStride ld == 1)) - shp dims (replicate (length dims - 1) False ++ [True])) - - -- Compose permutations, reverse strides and adjust offset if necessary. - let perm_base' = if hasContiguousPerm ixfun - then perm_base - else map (perm !!) perm_base - lmad_base' = setLMADPermutation perm_base' lmad_base - dims_base = lmadDims lmad_base' - n_fewer_dims = length dims_base - length dims - (dims_base', offs_contrib) = unzip $ - zipWith (\(LMADDim s1 r1 n1 p1 _) (LMADDim _ r2 _ _ m2) -> - let (s', off') | m2 == Inc = (s1, 0) - | otherwise = (s1 * (-1), s1 * (n1 - 1)) - r' | m2 == Inc = if r2 == 0 then r1 else r1 + r2 - | r1 == 0 = r2 - | r2 == 0 = n1 - r1 - | otherwise = n1 - r1 + r2 - in (LMADDim s' r' n1 (p1 - n_fewer_dims) Inc, off')) - -- If @dims@ is morally a slice, it might have fewer dimensions than - -- @dims_base@. Drop extraneous outer dimensions. - (drop n_fewer_dims dims_base) dims - off_base = lmadOffset lmad_base' + sum offs_contrib - lmad_base'' - | lmadOffset lmad == 0 = LMAD off_base dims_base' - | otherwise = - -- If the innermost dimension of the ixfun was not full (but still - -- had a stride of 1), add its offset relative to the new base. - setLMADShape (lmadShape lmad) - (LMAD (off_base + ldStride (last dims_base) * lmadOffset lmad) - dims_base') - new_base' = IxFun (lmad_base'' :| lmads_base) shp cg_base - IxFun lmads_base' _ _ = if all null outer_shapes && null inner_shape - then new_base' - else repeat new_base' outer_shapes inner_shape - lmads'' = lmads' ++@ lmads_base' - return $ IxFun lmads'' shp (cg && cg_base) - where shaveoffRepeats :: (Eq num, IntegralExp num) => - LMAD num -> (([Shape num], Shape num), LMAD num) - shaveoffRepeats lmad = - -- Given an input lmad, this function computes a repetition @r@ and a new lmad - -- @res@, such that @repeat r res@ is identical to the input lmad. - let perm = lmadPermutation lmad - dims = lmadDims lmad - -- compute the Repeat: - resacc= foldl (\acc (LMADDim s _ n _ _) -> - case acc of - rpt : acc0 -> - if s == 0 then (n : rpt) : acc0 - else [] : (rpt : acc0) - _ -> error "shaveoffRepeats: empty accumulator" - ) [[]] $ reverse $ permuteFwd perm dims - last_shape = last resacc - shapes = take (length resacc - 1) resacc - -- update permutation and lmad: - howManyRepLT k = - foldl (\i (LMADDim s _ _ p _) -> - if s == 0 && p < k then i + 1 else i - ) 0 dims - dims' = foldl (\acc (LMADDim s r n p info) -> - if s == 0 then acc - else let p' = p - howManyRepLT p - in LMADDim s r n p' info : acc - ) [] $ reverse dims - lmad' = LMAD (lmadOffset lmad) dims' - in ((shapes, last_shape), lmad') - --- | Rebase an index function on top of a new base. -rebase :: (Eq num, IntegralExp num) => - IxFun num -> IxFun num -> IxFun num -rebase new_base@(IxFun lmads_base shp_base cg_base) ixfun@(IxFun lmads shp cg) - | Just ixfun' <- rebaseNice new_base ixfun = ixfun' - -- In the general case just concatenate LMADs since this refers to index - -- function composition, which is always safe. - | otherwise = - let (lmads_base', shp_base') = - if base ixfun == shape new_base - then (lmads_base, shp_base) - else let IxFun lmads' shp_base'' _ = reshape new_base $ map DimCoercion shp - in (lmads', shp_base'') - in IxFun (lmads @++@ lmads_base') shp_base' (cg && cg_base) - -ixfunMonotonicity :: (Eq num, IntegralExp num) => IxFun num -> Monotonicity -ixfunMonotonicity = ixfunMonotonicityRots False - --- | Offset index. Results in the index function corresponding to indexing with --- @i@ on the outermost dimension. -offsetIndex :: (Eq num, IntegralExp num) => - IxFun num -> num -> IxFun num -offsetIndex ixfun i | i == 0 = ixfun -offsetIndex ixfun i = - case shape ixfun of - d : ds -> slice ixfun (DimSlice i (d - i) 1 : map (unitSlice 0) ds) - [] -> error "offsetIndex: underlying index function has rank zero" - --- | If the memory support of the index function is contiguous and row-major --- (i.e., no transpositions, repetitions, rotates, etc.), then this should --- return the offset from which the memory-support of this index function --- starts. -linearWithOffset :: (Eq num, IntegralExp num) => - IxFun num -> num -> Maybe num -linearWithOffset ixfun@(IxFun (lmad :| []) _ cg) elem_size - | hasContiguousPerm ixfun && cg && ixfunMonotonicity ixfun == Inc = - Just $ lmadOffset lmad * elem_size -linearWithOffset _ _ = Nothing - --- | Similar restrictions to @linearWithOffset@ except for transpositions, which --- are returned together with the offset. -rearrangeWithOffset :: (Eq num, IntegralExp num) => - IxFun num -> num -> Maybe (num, [(Int,num)]) -rearrangeWithOffset (IxFun (lmad :| []) oshp cg) elem_size = do - -- Note that @cg@ describes whether the index function is - -- contiguous, *ignoring permutations*. This function requires that - -- functionality. - let perm = lmadPermutation lmad - perm_contig = [0..length perm-1] - offset <- linearWithOffset - (IxFun (setLMADPermutation perm_contig lmad :| []) oshp cg) elem_size - return (offset, zip perm (permuteFwd perm (lmadShapeBase lmad))) -rearrangeWithOffset _ _ = Nothing - -isLinear :: (Eq num, IntegralExp num) => IxFun num -> Bool -isLinear = (== Just 0) . flip linearWithOffset 1 - -permuteFwd :: Permutation -> [a] -> [a] -permuteFwd ps elems = map (elems !!) ps - -permuteInv :: Permutation -> [a] -> [a] -permuteInv ps elems = map snd $ sortBy (compare `on` fst) $ zip ps elems - -flatOneDim :: (Eq num, IntegralExp num) => - (num, num, num) -> num -> num -flatOneDim (s, r, n) i - | s == 0 = 0 - | r == 0 = i * s - | otherwise = ((i + r) `mod` n) * s - --- | Generalised iota with user-specified offset and strides. -makeRotIota :: IntegralExp num => - Monotonicity -> num -> [(num, num)] -> LMAD num -makeRotIota mon off support - | mon == Inc || mon == Dec = - let rk = length support - (rs, ns) = unzip support - ss0 = reverse $ take rk $ scanl (*) 1 $ reverse ns - ss = if mon == Inc - then ss0 - else map (* (-1)) ss0 - ps = map fromIntegral [0..rk-1] - fi = replicate rk mon - in LMAD off $ zipWith5 LMADDim ss rs ns ps fi - | otherwise = error "makeRotIota: requires Inc or Dec" - --- | Check monotonicity of an index function. -ixfunMonotonicityRots :: (Eq num, IntegralExp num) => - Bool -> IxFun num -> Monotonicity -ixfunMonotonicityRots ignore_rots (IxFun (lmad :| lmads) _ _) = - let mon0 = lmadMonotonicityRots lmad - in if all ((== mon0) . lmadMonotonicityRots) lmads - then mon0 - else Unknown - where lmadMonotonicityRots :: (Eq num, IntegralExp num) => - LMAD num -> Monotonicity - lmadMonotonicityRots (LMAD _ dims) - | all (isMonDim Inc) dims = Inc - | all (isMonDim Dec) dims = Dec - | otherwise = Unknown - - isMonDim :: (Eq num, IntegralExp num) => - Monotonicity -> LMADDim num -> Bool - isMonDim mon (LMADDim s r _ _ ldmon) = - s == 0 || ((ignore_rots || r == 0) && mon == ldmon) - --- | Generalization (anti-unification) --- --- Anti-unification of two index functions is supported under the following conditions: --- 0. Both index functions are represented by ONE lmad (assumed common case!) --- 1. The support array of the two indexfuns have the same dimensionality --- (we can relax this condition if we use a 1D support, as we probably should!) --- 2. The contiguous property and the per-dimension monotonicity are the same --- (otherwise we might loose important information; this can be relaxed!) --- 3. Most importantly, both index functions correspond to the same permutation --- (since the permutation is represented by INTs, this restriction cannot --- be relaxed, unless we move to a gated-LMAD representation!) --- --- `k0` is the existential to use for the shape of the array. -leastGeneralGeneralization :: Eq v => IxFun (PrimExp v) -> IxFun (PrimExp v) -> - Maybe (IxFun (PrimExp (Ext v)), [(PrimExp v, PrimExp v)]) -leastGeneralGeneralization (IxFun (lmad1 :| []) oshp1 ctg1) (IxFun (lmad2 :| []) oshp2 ctg2) = do - guard $ - length oshp1 == length oshp2 && - ctg1 == ctg2 && - map ldPerm (lmadDims lmad1) == map ldPerm (lmadDims lmad2) && - lmadDMon lmad1 == lmadDMon lmad2 - let (ctg, dperm, dmon) = (ctg1, lmadPermutation lmad1, lmadDMon lmad1) - (dshp, m1) <- generalize [] (lmadDShp lmad1) (lmadDShp lmad2) - (oshp, m2) <- generalize m1 oshp1 oshp2 - (dstd, m3) <- generalize m2 (lmadDSrd lmad1) (lmadDSrd lmad2) - (drot, m4) <- generalize m3 (lmadDRot lmad1) (lmadDRot lmad2) - (offt, m5) <- PEG.leastGeneralGeneralization m4 (lmadOffset lmad1) (lmadOffset lmad2) - let lmad_dims = map (\(a,b,c,d,e) -> LMADDim a b c d e) $ - zip5 dstd drot dshp dperm dmon - lmad = LMAD offt lmad_dims - return (IxFun (lmad :| []) oshp ctg, m5) - where lmadDMon = map ldMon . lmadDims - lmadDSrd = map ldStride . lmadDims - lmadDShp = map ldShape . lmadDims - lmadDRot = map ldRotate . lmadDims - generalize m l1 l2 = - foldM (\(l_acc, m') (pe1,pe2) -> do - (e, m'') <- PEG.leastGeneralGeneralization m' pe1 pe2 - return (l_acc++[e], m'') - ) ([], m) (zip l1 l2) -leastGeneralGeneralization _ _ = Nothing - --- | When comparing index functions as part of the type check in KernelsMem, --- we may run into problems caused by the simplifier. As index functions can be --- generalized over if-then-else expressions, the simplifier might hoist some of --- the code from inside the if-then-else (computing the offset of an array, for --- instance), but now the type checker cannot verify that the generalized index --- function is valid, because some of the existentials are computed somewhere --- else. To Work around this, we've had to relax the KernelsMem type-checker --- a bit, specifically, we've introduced this function to verify whether two --- index functions are "close enough" that we can assume that they match. We use --- this instead of `ixfun1 == ixfun2` and hope that it's good enough. -closeEnough :: IxFun num -> IxFun num -> Bool -closeEnough ixf1 ixf2 = - (length (base ixf1) == length (base ixf2)) && - (ixfunContig ixf1 == ixfunContig ixf2) && - (NE.length (ixfunLMADs ixf1) == NE.length (ixfunLMADs ixf2)) && - all closeEnoughLMADs (NE.zip (ixfunLMADs ixf1) (ixfunLMADs ixf2)) - where - closeEnoughLMADs :: (LMAD num, LMAD num) -> Bool - closeEnoughLMADs (lmad1, lmad2) = - length (lmadDims lmad1) == length (lmadDims lmad2) && - map ldPerm (lmadDims lmad1) == - map ldPerm (lmadDims lmad2) diff --git a/src/Futhark/Representation/Mem/Simplify.hs b/src/Futhark/Representation/Mem/Simplify.hs deleted file mode 100644 --- a/src/Futhark/Representation/Mem/Simplify.hs +++ /dev/null @@ -1,216 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ConstraintKinds #-} -module Futhark.Representation.Mem.Simplify - ( simplifyProgGeneric - , simplifyStmsGeneric - , simpleGeneric - , SimplifyMemory - ) -where - -import Control.Monad -import Data.List (find) - -import qualified Futhark.Representation.AST.Syntax as AST -import Futhark.Representation.AST.Syntax - hiding (Prog, BasicOp, Exp, Body, Stm, - Pattern, PatElem, Lambda, FunDef, FParam, LParam, RetType) -import Futhark.Representation.Mem -import qualified Futhark.Representation.Mem.IxFun as IxFun -import Futhark.Pass.ExplicitAllocations (simplifiable) -import qualified Futhark.Analysis.SymbolTable as ST -import qualified Futhark.Analysis.UsageTable as UT -import qualified Futhark.Optimise.Simplify.Engine as Engine -import qualified Futhark.Optimise.Simplify as Simplify -import Futhark.Construct -import Futhark.Pass -import Futhark.Optimise.Simplify.Rules -import Futhark.Optimise.Simplify.Rule -import Futhark.Optimise.Simplify.Lore -import Futhark.Util - -simpleGeneric :: (SimplifyMemory lore, Op lore ~ MemOp inner) => - Simplify.SimplifyOp lore inner - -> Simplify.SimpleOps lore -simpleGeneric = simplifiable - -simplifyProgGeneric :: (SimplifyMemory lore, - Op lore ~ MemOp inner) => - Simplify.SimplifyOp lore inner - -> Prog lore -> PassM (Prog lore) -simplifyProgGeneric onInner = - Simplify.simplifyProg (simpleGeneric onInner) callKernelRules - blockers { Engine.blockHoistBranch = blockAllocs } - where blockAllocs vtable _ (Let _ _ (Op Alloc{})) = - not $ ST.simplifyMemory vtable - -- Do not hoist statements that produce arrays. This is - -- because in the KernelsMem representation, multiple - -- arrays can be located in the same memory block, and moving - -- their creation out of a branch can thus cause memory - -- corruption. At this point in the compiler we have probably - -- already moved all the array creations that matter. - blockAllocs _ _ (Let pat _ _) = - not $ all primType $ patternTypes pat - -simplifyStmsGeneric :: (HasScope lore m, MonadFreshNames m, - SimplifyMemory lore, Op lore ~ MemOp inner) => - Simplify.SimplifyOp lore inner -> Stms lore - -> m (ST.SymbolTable (Wise lore), Stms lore) -simplifyStmsGeneric onInner stms = do - scope <- askScope - Simplify.simplifyStms (simpleGeneric onInner) callKernelRules blockers - scope stms - -isResultAlloc :: Op lore ~ MemOp op => Engine.BlockPred lore -isResultAlloc _ usage (Let (AST.Pattern [] [bindee]) _ (Op Alloc{})) = - UT.isInResult (patElemName bindee) usage -isResultAlloc _ _ _ = False - --- | Getting the roots of what to hoist, for now only variable --- names that represent array and memory-block sizes. -getShapeNames :: (Mem lore, Op lore ~ MemOp op) => - Stm (Wise lore) -> Names -getShapeNames stm = - let ts = map patElemType $ patternElements $ stmPattern stm - in freeIn (concatMap arrayDims ts) <> - case stmExp stm of Op (Alloc size _) -> freeIn size - _ -> mempty - -isAlloc :: Op lore ~ MemOp op => Engine.BlockPred lore -isAlloc _ _ (Let _ _ (Op Alloc{})) = True -isAlloc _ _ _ = False - -blockers :: (Mem lore, Op lore ~ MemOp inner) => - Simplify.HoistBlockers lore -blockers = Engine.noExtraHoistBlockers { - Engine.blockHoistPar = isAlloc - , Engine.blockHoistSeq = isResultAlloc - , Engine.getArraySizes = getShapeNames - , Engine.isAllocation = isAlloc mempty mempty - } - --- | Some constraints that must hold for the simplification rules to work. -type SimplifyMemory lore = - (Simplify.SimplifiableLore lore, - ExpAttr lore ~ (), - BodyAttr lore ~ (), - AllocOp (Op (Wise lore)), - CanBeWise (Op lore), - BinderOps (Wise lore), - Mem lore) - -callKernelRules :: SimplifyMemory lore => RuleBook (Wise lore) -callKernelRules = standardRules <> - ruleBook [RuleBasicOp copyCopyToCopy, - RuleBasicOp removeIdentityCopy, - RuleIf unExistentialiseMemory] [] - --- | If a branch is returning some existential memory, but the size of --- the array is not existential, then we can create a block of the --- proper size and always return there. -unExistentialiseMemory :: SimplifyMemory lore => TopDownRuleIf (Wise lore) -unExistentialiseMemory vtable pat _ (cond, tbranch, fbranch, ifattr) - | ST.simplifyMemory vtable, - fixable <- foldl hasConcretisableMemory mempty $ patternElements pat, - not $ null fixable = Simplify $ do - - -- Create non-existential memory blocks big enough to hold the - -- arrays. - (arr_to_mem, oldmem_to_mem) <- - fmap unzip $ forM fixable $ \(arr_pe, mem_size, oldmem, space) -> do - size <- letSubExp "size" =<< toExp mem_size - mem <- letExp "mem" $ Op $ allocOp size space - return ((patElemName arr_pe, mem), (oldmem, mem)) - - -- Update the branches to contain Copy expressions putting the - -- arrays where they are expected. - let updateBody body = insertStmsM $ do - res <- bodyBind body - resultBodyM =<< - zipWithM updateResult (patternElements pat) res - updateResult pat_elem (Var v) - | Just mem <- lookup (patElemName pat_elem) arr_to_mem, - (_, MemArray pt shape u (ArrayIn _ ixfun)) <- patElemAttr pat_elem = do - v_copy <- newVName $ baseString v <> "_nonext_copy" - let v_pat = Pattern [] [PatElem v_copy $ - MemArray pt shape u $ ArrayIn mem ixfun] - addStm $ mkWiseLetStm v_pat (defAux ()) $ BasicOp (Copy v) - return $ Var v_copy - | Just mem <- lookup (patElemName pat_elem) oldmem_to_mem = - return $ Var mem - updateResult _ se = - return se - tbranch' <- updateBody tbranch - fbranch' <- updateBody fbranch - letBind_ pat $ If cond tbranch' fbranch' ifattr - where onlyUsedIn name here = not $ any ((name `nameIn`) . freeIn) $ - filter ((/=here) . patElemName) $ - patternValueElements pat - knownSize Constant{} = True - knownSize (Var v) = not $ inContext v - inContext = (`elem` patternContextNames pat) - - hasConcretisableMemory fixable pat_elem - | (_, MemArray pt shape _ (ArrayIn mem ixfun)) <- patElemAttr pat_elem, - Just (j, Mem space) <- - fmap patElemType <$> find ((mem==) . patElemName . snd) - (zip [(0::Int)..] $ patternElements pat), - Just tse <- maybeNth j $ bodyResult tbranch, - Just fse <- maybeNth j $ bodyResult fbranch, - mem `onlyUsedIn` patElemName pat_elem, - all knownSize (shapeDims shape), - fse /= tse = - let mem_size = - ConvOpExp (SExt Int32 Int64) $ - product $ primByteSize pt : IxFun.base ixfun - in (pat_elem, mem_size, mem, space) : fixable - | otherwise = - fixable -unExistentialiseMemory _ _ _ _ = Skip - --- | If we are copying something that is itself a copy, just copy the --- original one instead. -copyCopyToCopy :: (BinderOps lore, - LetAttr lore ~ (VarWisdom, MemBound u)) => - TopDownRuleBasicOp lore -copyCopyToCopy vtable pat@(Pattern [] [pat_elem]) _ (Copy v1) - | Just (BasicOp (Copy v2), v1_cs) <- ST.lookupExp v1 vtable, - - Just (_, MemArray _ _ _ (ArrayIn srcmem src_ixfun)) <- - ST.entryLetBoundAttr =<< ST.lookup v1 vtable, - - Just (Mem src_space) <- ST.lookupType srcmem vtable, - - (_, MemArray _ _ _ (ArrayIn destmem dest_ixfun)) <- patElemAttr pat_elem, - - Just (Mem dest_space) <- ST.lookupType destmem vtable, - - src_space == dest_space, dest_ixfun == src_ixfun = - - Simplify $ certifying v1_cs $ letBind_ pat $ BasicOp $ Copy v2 - -copyCopyToCopy vtable pat _ (Copy v0) - | Just (BasicOp (Rearrange perm v1), v0_cs) <- ST.lookupExp v0 vtable, - Just (BasicOp (Copy v2), v1_cs) <- ST.lookupExp v1 vtable = Simplify $ do - v0' <- certifying (v0_cs<>v1_cs) $ - letExp "rearrange_v0" $ BasicOp $ Rearrange perm v2 - letBind_ pat $ BasicOp $ Copy v0' - -copyCopyToCopy _ _ _ _ = Skip - --- | If the destination of a copy is the same as the source, just --- remove it. -removeIdentityCopy :: (BinderOps lore, - LetAttr lore ~ (VarWisdom, MemBound u)) => - TopDownRuleBasicOp lore -removeIdentityCopy vtable pat@(Pattern [] [pe]) _ (Copy v) - | (_, MemArray _ _ _ (ArrayIn dest_mem dest_ixfun)) <- patElemAttr pe, - Just (_, MemArray _ _ _ (ArrayIn src_mem src_ixfun)) <- - ST.entryLetBoundAttr =<< ST.lookup v vtable, - dest_mem == src_mem, dest_ixfun == src_ixfun = - Simplify $ letBind_ pat $ BasicOp $ SubExp $ Var v - -removeIdentityCopy _ _ _ _ = Skip diff --git a/src/Futhark/Representation/Primitive.hs b/src/Futhark/Representation/Primitive.hs deleted file mode 100644 --- a/src/Futhark/Representation/Primitive.hs +++ /dev/null @@ -1,1277 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE LambdaCase #-} --- | Definitions of primitive types, the values that inhabit these --- types, and operations on these values. A primitive value can also --- be called a scalar. --- --- Essentially, this module describes the subset of the (internal) --- Futhark language that operates on primitive types. -module Futhark.Representation.Primitive - ( -- * Types - IntType (..), allIntTypes - , FloatType (..), allFloatTypes - , PrimType (..), allPrimTypes - - -- * Values - , IntValue(..) - , intValue, intValueType, valueIntegral - , FloatValue(..) - , floatValue, floatValueType - , PrimValue(..) - , primValueType - , blankPrimValue - - -- * Operations - , Overflow (..) - , UnOp (..), allUnOps - , BinOp (..), allBinOps - , ConvOp (..), allConvOps - , CmpOp (..), allCmpOps - - -- ** Unary Operations - , doUnOp - , doComplement - , doAbs, doFAbs - , doSSignum, doUSignum - - -- ** Binary Operations - , doBinOp - , doAdd, doMul, doSDiv, doSMod - , doPow - - -- ** Conversion Operations - , doConvOp - , doZExt, doSExt - , doFPConv - , doFPToUI, doFPToSI - , doUIToFP, doSIToFP - , intToInt64, intToWord64 - - -- * Comparison Operations - , doCmpOp - , doCmpEq - , doCmpUlt, doCmpUle - , doCmpSlt, doCmpSle - , doFCmpLt, doFCmpLe - - -- * Type Of - , binOpType - , unOpType - , cmpOpType - , convOpType - - -- * Primitive functions - , primFuns - - -- * Utility - , zeroIsh - , zeroIshInt - , oneIsh - , oneIshInt - , negativeIsh - , primBitSize - , primByteSize - , intByteSize - , floatByteSize - , commutativeBinOp - - -- * Prettyprinting - , convOpFun - , prettySigned - ) - where - -import Control.Applicative -import Data.Binary.IEEE754 (floatToWord, wordToFloat, doubleToWord, wordToDouble) -import Data.Bits -import Data.Fixed (mod') -- Weird location. -import Data.Int (Int16, Int32, Int64, Int8) -import qualified Data.Map as M -import Data.Word - -import Prelude - -import Futhark.Util.Pretty -import Futhark.Util (roundFloat, ceilFloat, floorFloat, - roundDouble, ceilDouble, floorDouble, - lgamma, lgammaf, tgamma, tgammaf) - --- | An integer type, ordered by size. Note that signedness is not a --- property of the type, but a property of the operations performed on --- values of these types. -data IntType = Int8 - | Int16 - | Int32 - | Int64 - deriving (Eq, Ord, Show, Enum, Bounded) - -instance Pretty IntType where - ppr Int8 = text "i8" - ppr Int16 = text "i16" - ppr Int32 = text "i32" - ppr Int64 = text "i64" - --- | A list of all integer types. -allIntTypes :: [IntType] -allIntTypes = [minBound..maxBound] - --- | A floating point type. -data FloatType = Float32 - | Float64 - deriving (Eq, Ord, Show, Enum, Bounded) - -instance Pretty FloatType where - ppr Float32 = text "f32" - ppr Float64 = text "f64" - --- | A list of all floating-point types. -allFloatTypes :: [FloatType] -allFloatTypes = [minBound..maxBound] - --- | Low-level primitive types. -data PrimType = IntType IntType - | FloatType FloatType - | Bool - | Cert - deriving (Eq, Ord, Show) - -instance Enum PrimType where - toEnum 0 = IntType Int8 - toEnum 1 = IntType Int16 - toEnum 2 = IntType Int32 - toEnum 3 = IntType Int64 - toEnum 4 = FloatType Float32 - toEnum 5 = FloatType Float64 - toEnum 6 = Bool - toEnum _ = Cert - - fromEnum (IntType Int8) = 0 - fromEnum (IntType Int16) = 1 - fromEnum (IntType Int32) = 2 - fromEnum (IntType Int64) = 3 - fromEnum (FloatType Float32) = 4 - fromEnum (FloatType Float64) = 5 - fromEnum Bool = 6 - fromEnum Cert = 7 - -instance Bounded PrimType where - minBound = IntType Int8 - maxBound = Cert - -instance Pretty PrimType where - ppr (IntType t) = ppr t - ppr (FloatType t) = ppr t - ppr Bool = text "bool" - ppr Cert = text "cert" - --- | A list of all primitive types. -allPrimTypes :: [PrimType] -allPrimTypes = map IntType allIntTypes ++ - map FloatType allFloatTypes ++ - [Bool, Cert] - --- | An integer value. -data IntValue = Int8Value !Int8 - | Int16Value !Int16 - | Int32Value !Int32 - | Int64Value !Int64 - deriving (Eq, Ord, Show) - -instance Pretty IntValue where - ppr (Int8Value v) = text $ show v ++ "i8" - ppr (Int16Value v) = text $ show v ++ "i16" - ppr (Int32Value v) = text $ show v ++ "i32" - ppr (Int64Value v) = text $ show v ++ "i64" - --- | Create an 'IntValue' from a type and an 'Integer'. -intValue :: Integral int => IntType -> int -> IntValue -intValue Int8 = Int8Value . fromIntegral -intValue Int16 = Int16Value . fromIntegral -intValue Int32 = Int32Value . fromIntegral -intValue Int64 = Int64Value . fromIntegral - --- | The type of an integer value. -intValueType :: IntValue -> IntType -intValueType Int8Value{} = Int8 -intValueType Int16Value{} = Int16 -intValueType Int32Value{} = Int32 -intValueType Int64Value{} = Int64 - --- | Convert an 'IntValue' to any 'Integral' type. -valueIntegral ::Integral int => IntValue -> int -valueIntegral (Int8Value v) = fromIntegral v -valueIntegral (Int16Value v) = fromIntegral v -valueIntegral (Int32Value v) = fromIntegral v -valueIntegral (Int64Value v) = fromIntegral v - --- | A floating-point value. -data FloatValue = Float32Value !Float - | Float64Value !Double - deriving (Eq, Ord, Show) - - -instance Pretty FloatValue where - ppr (Float32Value v) - | isInfinite v, v >= 0 = text "f32.inf" - | isInfinite v, v < 0 = text "-f32.inf" - | isNaN v = text "f32.nan" - | otherwise = text $ show v ++ "f32" - ppr (Float64Value v) - | isInfinite v, v >= 0 = text "f64.inf" - | isInfinite v, v < 0 = text "-f64.inf" - | isNaN v = text "f64.nan" - | otherwise = text $ show v ++ "f64" - --- | Create a 'FloatValue' from a type and a 'Rational'. -floatValue :: Real num => FloatType -> num -> FloatValue -floatValue Float32 = Float32Value . fromRational . toRational -floatValue Float64 = Float64Value . fromRational . toRational - --- | The type of a floating-point value. -floatValueType :: FloatValue -> FloatType -floatValueType Float32Value{} = Float32 -floatValueType Float64Value{} = Float64 - --- | Non-array values. -data PrimValue = IntValue !IntValue - | FloatValue !FloatValue - | BoolValue !Bool - | Checked -- ^ The only value of type @cert@. - deriving (Eq, Ord, Show) - -instance Pretty PrimValue where - ppr (IntValue v) = ppr v - ppr (BoolValue True) = text "true" - ppr (BoolValue False) = text "false" - ppr (FloatValue v) = ppr v - ppr Checked = text "checked" - --- | The type of a basic value. -primValueType :: PrimValue -> PrimType -primValueType (IntValue v) = IntType $ intValueType v -primValueType (FloatValue v) = FloatType $ floatValueType v -primValueType BoolValue{} = Bool -primValueType Checked = Cert - --- | A "blank" value of the given primitive type - this is zero, or --- whatever is close to it. Don't depend on this value, but use it --- for e.g. creating arrays to be populated by do-loops. -blankPrimValue :: PrimType -> PrimValue -blankPrimValue (IntType Int8) = IntValue $ Int8Value 0 -blankPrimValue (IntType Int16) = IntValue $ Int16Value 0 -blankPrimValue (IntType Int32) = IntValue $ Int32Value 0 -blankPrimValue (IntType Int64) = IntValue $ Int64Value 0 -blankPrimValue (FloatType Float32) = FloatValue $ Float32Value 0.0 -blankPrimValue (FloatType Float64) = FloatValue $ Float64Value 0.0 -blankPrimValue Bool = BoolValue False -blankPrimValue Cert = Checked - --- | Various unary operators. It is a bit ad-hoc what is a unary --- operator and what is a built-in function. Perhaps these should all --- go away eventually. -data UnOp = Not -- ^ E.g., @! True == False@. - | Complement IntType -- ^ E.g., @~(~1) = 1@. - | Abs IntType -- ^ @abs(-2) = 2@. - | FAbs FloatType -- ^ @fabs(-2.0) = 2.0@. - | SSignum IntType -- ^ Signed sign function: @ssignum(-2)@ = -1. - | USignum IntType -- ^ Unsigned sign function: @usignum(2)@ = 1. - deriving (Eq, Ord, Show) - --- | What to do in case of arithmetic overflow. Futhark's semantics --- are that overflow does wraparound, but for generated code (like --- address arithmetic), it can be beneficial for overflow to be --- undefined behaviour, as it allows better optimisation of things --- such as GPU kernels. --- --- Note that all values of this type are considered equal for 'Eq' and --- 'Ord'. -data Overflow = OverflowWrap | OverflowUndef - deriving (Show) - -instance Eq Overflow where - _ == _ = True - -instance Ord Overflow where - _ `compare` _ = EQ - --- | Binary operators. These correspond closely to the binary operators in --- LLVM. Most are parametrised by their expected input and output --- types. -data BinOp = Add IntType Overflow -- ^ Integer addition. - | FAdd FloatType -- ^ Floating-point addition. - - | Sub IntType Overflow -- ^ Integer subtraction. - | FSub FloatType -- ^ Floating-point subtraction. - - | Mul IntType Overflow -- ^ Integer multiplication. - | FMul FloatType -- ^ Floating-point multiplication. - - | UDiv IntType - -- ^ Unsigned integer division. Rounds towards - -- negativity infinity. Note: this is different - -- from LLVM. - | SDiv IntType - -- ^ Signed integer division. Rounds towards - -- negativity infinity. Note: this is different - -- from LLVM. - | FDiv FloatType -- ^ Floating-point division. - | FMod FloatType -- ^ Floating-point modulus. - - | UMod IntType - -- ^ Unsigned integer modulus; the countepart to 'UDiv'. - | SMod IntType - -- ^ Signed integer modulus; the countepart to 'SDiv'. - - | SQuot IntType - -- ^ Signed integer division. Rounds towards zero. - -- This corresponds to the @sdiv@ instruction in LLVM. - | SRem IntType - -- ^ Signed integer division. Rounds towards zero. - -- This corresponds to the @srem@ instruction in LLVM. - - | SMin IntType - -- ^ Returns the smallest of two signed integers. - | UMin IntType - -- ^ Returns the smallest of two unsigned integers. - | FMin FloatType - -- ^ Returns the smallest of two floating-point numbers. - | SMax IntType - -- ^ Returns the greatest of two signed integers. - | UMax IntType - -- ^ Returns the greatest of two unsigned integers. - | FMax FloatType - -- ^ Returns the greatest of two floating-point numbers. - - | Shl IntType -- ^ Left-shift. - | LShr IntType -- ^ Logical right-shift, zero-extended. - | AShr IntType -- ^ Arithmetic right-shift, sign-extended. - - | And IntType -- ^ Bitwise and. - | Or IntType -- ^ Bitwise or. - | Xor IntType -- ^ Bitwise exclusive-or. - - | Pow IntType -- ^ Integer exponentiation. - | FPow FloatType -- ^ Floating-point exponentiation. - - | LogAnd -- ^ Boolean and - not short-circuiting. - | LogOr -- ^ Boolean or - not short-circuiting. - deriving (Eq, Ord, Show) - --- | Comparison operators are like 'BinOp's, but they return 'Bool's. --- The somewhat ugly constructor names are straight out of LLVM. -data CmpOp = CmpEq PrimType -- ^ All types equality. - | CmpUlt IntType -- ^ Unsigned less than. - | CmpUle IntType -- ^ Unsigned less than or equal. - | CmpSlt IntType -- ^ Signed less than. - | CmpSle IntType -- ^ Signed less than or equal. - - -- Comparison operators for floating-point values. TODO: extend - -- this to handle NaNs and such, like the LLVM fcmp instruction. - | FCmpLt FloatType -- ^ Floating-point less than. - | FCmpLe FloatType -- ^ Floating-point less than or equal. - - -- Boolean comparison. - | CmpLlt -- ^ Boolean less than. - | CmpLle -- ^ Boolean less than or equal. - deriving (Eq, Ord, Show) - --- | Conversion operators try to generalise the @from t0 x to t1@ --- instructions from LLVM. -data ConvOp = ZExt IntType IntType - -- ^ Zero-extend the former integer type to the latter. - -- If the new type is smaller, the result is a - -- truncation. - | SExt IntType IntType - -- ^ Sign-extend the former integer type to the latter. - -- If the new type is smaller, the result is a - -- truncation. - | FPConv FloatType FloatType - -- ^ Convert value of the former floating-point type to - -- the latter. If the new type is smaller, the result - -- is a truncation. - | FPToUI FloatType IntType - -- ^ Convert a floating-point value to the nearest - -- unsigned integer (rounding towards zero). - | FPToSI FloatType IntType - -- ^ Convert a floating-point value to the nearest - -- signed integer (rounding towards zero). - | UIToFP IntType FloatType - -- ^ Convert an unsigned integer to a floating-point value. - | SIToFP IntType FloatType - -- ^ Convert a signed integer to a floating-point value. - | IToB IntType - -- ^ Convert an integer to a boolean value. Zero - -- becomes false; anything else is true. - | BToI IntType - -- ^ Convert a boolean to an integer. True is converted - -- to 1 and False to 0. - deriving (Eq, Ord, Show) - --- | A list of all unary operators for all types. -allUnOps :: [UnOp] -allUnOps = Not : - map Complement [minBound..maxBound] ++ - map Abs [minBound..maxBound] ++ - map FAbs [minBound..maxBound] ++ - map SSignum [minBound..maxBound] ++ - map USignum [minBound..maxBound] - --- | A list of all binary operators for all types. -allBinOps :: [BinOp] -allBinOps = concat [ map (`Add` OverflowWrap) allIntTypes - , map FAdd allFloatTypes - , map (`Sub` OverflowWrap) allIntTypes - , map FSub allFloatTypes - , map (`Mul` OverflowWrap) allIntTypes - , map FMul allFloatTypes - , map UDiv allIntTypes - , map SDiv allIntTypes - , map FDiv allFloatTypes - , map FMod allFloatTypes - , map UMod allIntTypes - , map SMod allIntTypes - , map SQuot allIntTypes - , map SRem allIntTypes - , map SMin allIntTypes - , map UMin allIntTypes - , map FMin allFloatTypes - , map SMax allIntTypes - , map UMax allIntTypes - , map FMax allFloatTypes - , map Shl allIntTypes - , map LShr allIntTypes - , map AShr allIntTypes - , map And allIntTypes - , map Or allIntTypes - , map Xor allIntTypes - , map Pow allIntTypes - , map FPow allFloatTypes - , [LogAnd, LogOr] - ] - --- | A list of all comparison operators for all types. -allCmpOps :: [CmpOp] -allCmpOps = concat [ map CmpEq allPrimTypes - , map CmpUlt allIntTypes - , map CmpUle allIntTypes - , map CmpSlt allIntTypes - , map CmpSle allIntTypes - , map FCmpLt allFloatTypes - , map FCmpLe allFloatTypes - ] - --- | A list of all conversion operators for all types. -allConvOps :: [ConvOp] -allConvOps = concat [ ZExt <$> allIntTypes <*> allIntTypes - , SExt <$> allIntTypes <*> allIntTypes - , FPConv <$> allFloatTypes <*> allFloatTypes - , FPToUI <$> allFloatTypes <*> allIntTypes - , FPToSI <$> allFloatTypes <*> allIntTypes - , UIToFP <$> allIntTypes <*> allFloatTypes - , SIToFP <$> allIntTypes <*> allFloatTypes - , IToB <$> allIntTypes - , BToI <$> allIntTypes - ] - --- | Apply an 'UnOp' to an operand. Returns 'Nothing' if the --- application is mistyped. -doUnOp :: UnOp -> PrimValue -> Maybe PrimValue -doUnOp Not (BoolValue b) = Just $ BoolValue $ not b -doUnOp Complement{} (IntValue v) = Just $ IntValue $ doComplement v -doUnOp Abs{} (IntValue v) = Just $ IntValue $ doAbs v -doUnOp FAbs{} (FloatValue v) = Just $ FloatValue $ doFAbs v -doUnOp SSignum{} (IntValue v) = Just $ IntValue $ doSSignum v -doUnOp USignum{} (IntValue v) = Just $ IntValue $ doUSignum v -doUnOp _ _ = Nothing - --- | E.g., @~(~1) = 1@. -doComplement :: IntValue -> IntValue -doComplement v = intValue (intValueType v) $ complement $ intToInt64 v - --- | @abs(-2) = 2@. -doAbs :: IntValue -> IntValue -doAbs v = intValue (intValueType v) $ abs $ intToInt64 v - --- | @abs(-2.0) = 2.0@. -doFAbs :: FloatValue -> FloatValue -doFAbs v = floatValue (floatValueType v) $ abs $ floatToDouble v - --- | @ssignum(-2)@ = -1. -doSSignum :: IntValue -> IntValue -doSSignum v = intValue (intValueType v) $ signum $ intToInt64 v - --- | @usignum(-2)@ = -1. -doUSignum :: IntValue -> IntValue -doUSignum v = intValue (intValueType v) $ signum $ intToWord64 v - --- | Apply a 'BinOp' to an operand. Returns 'Nothing' if the --- application is mistyped, or outside the domain (e.g. division by --- zero). -doBinOp :: BinOp -> PrimValue -> PrimValue -> Maybe PrimValue -doBinOp Add{} = doIntBinOp doAdd -doBinOp FAdd{} = doFloatBinOp (+) (+) -doBinOp Sub{} = doIntBinOp doSub -doBinOp FSub{} = doFloatBinOp (-) (-) -doBinOp Mul{} = doIntBinOp doMul -doBinOp FMul{} = doFloatBinOp (*) (*) -doBinOp UDiv{} = doRiskyIntBinOp doUDiv -doBinOp SDiv{} = doRiskyIntBinOp doSDiv -doBinOp FDiv{} = doFloatBinOp (/) (/) -doBinOp FMod{} = doFloatBinOp mod' mod' -doBinOp UMod{} = doRiskyIntBinOp doUMod -doBinOp SMod{} = doRiskyIntBinOp doSMod -doBinOp SQuot{} = doRiskyIntBinOp doSQuot -doBinOp SRem{} = doRiskyIntBinOp doSRem -doBinOp SMin{} = doIntBinOp doSMin -doBinOp UMin{} = doIntBinOp doUMin -doBinOp FMin{} = doFloatBinOp min min -doBinOp SMax{} = doIntBinOp doSMax -doBinOp UMax{} = doIntBinOp doUMax -doBinOp FMax{} = doFloatBinOp max max -doBinOp Shl{} = doIntBinOp doShl -doBinOp LShr{} = doIntBinOp doLShr -doBinOp AShr{} = doIntBinOp doAShr -doBinOp And{} = doIntBinOp doAnd -doBinOp Or{} = doIntBinOp doOr -doBinOp Xor{} = doIntBinOp doXor -doBinOp Pow{} = doRiskyIntBinOp doPow -doBinOp FPow{} = doFloatBinOp (**) (**) -doBinOp LogAnd{} = doBoolBinOp (&&) -doBinOp LogOr{} = doBoolBinOp (||) - -doIntBinOp :: (IntValue -> IntValue -> IntValue) -> PrimValue -> PrimValue - -> Maybe PrimValue -doIntBinOp f (IntValue v1) (IntValue v2) = - Just $ IntValue $ f v1 v2 -doIntBinOp _ _ _ = Nothing - -doRiskyIntBinOp :: (IntValue -> IntValue -> Maybe IntValue) -> PrimValue -> PrimValue - -> Maybe PrimValue -doRiskyIntBinOp f (IntValue v1) (IntValue v2) = - IntValue <$> f v1 v2 -doRiskyIntBinOp _ _ _ = Nothing - -doFloatBinOp :: (Float -> Float -> Float) - -> (Double -> Double -> Double) - -> PrimValue -> PrimValue - -> Maybe PrimValue -doFloatBinOp f32 _ (FloatValue (Float32Value v1)) (FloatValue (Float32Value v2)) = - Just $ FloatValue $ Float32Value $ f32 v1 v2 -doFloatBinOp _ f64 (FloatValue (Float64Value v1)) (FloatValue (Float64Value v2)) = - Just $ FloatValue $ Float64Value $ f64 v1 v2 -doFloatBinOp _ _ _ _ = Nothing - -doBoolBinOp :: (Bool -> Bool -> Bool) -> PrimValue -> PrimValue - -> Maybe PrimValue -doBoolBinOp f (BoolValue v1) (BoolValue v2) = - Just $ BoolValue $ f v1 v2 -doBoolBinOp _ _ _ = Nothing - --- | Integer addition. -doAdd :: IntValue -> IntValue -> IntValue -doAdd v1 v2 = intValue (intValueType v1) $ intToInt64 v1 + intToInt64 v2 - --- | Integer subtraction. -doSub :: IntValue -> IntValue -> IntValue -doSub v1 v2 = intValue (intValueType v1) $ intToInt64 v1 - intToInt64 v2 - --- | Integer multiplication. -doMul :: IntValue -> IntValue -> IntValue -doMul v1 v2 = intValue (intValueType v1) $ intToInt64 v1 * intToInt64 v2 - --- | Unsigned integer division. Rounds towards --- negativity infinity. Note: this is different --- from LLVM. -doUDiv :: IntValue -> IntValue -> Maybe IntValue -doUDiv v1 v2 - | zeroIshInt v2 = Nothing - | otherwise = Just $ intValue (intValueType v1) $ intToWord64 v1 `div` intToWord64 v2 - --- | Signed integer division. Rounds towards --- negativity infinity. Note: this is different --- from LLVM. -doSDiv :: IntValue -> IntValue -> Maybe IntValue -doSDiv v1 v2 - | zeroIshInt v2 = Nothing - | otherwise = Just $ intValue (intValueType v1) $ intToInt64 v1 `div` intToInt64 v2 - --- | Unsigned integer modulus; the countepart to 'UDiv'. -doUMod :: IntValue -> IntValue -> Maybe IntValue -doUMod v1 v2 - | zeroIshInt v2 = Nothing - | otherwise = Just $ intValue (intValueType v1) $ intToWord64 v1 `mod` intToWord64 v2 - --- | Signed integer modulus; the countepart to 'SDiv'. -doSMod :: IntValue -> IntValue -> Maybe IntValue -doSMod v1 v2 - | zeroIshInt v2 = Nothing - | otherwise = Just $ intValue (intValueType v1) $ intToInt64 v1 `mod` intToInt64 v2 - --- | Signed integer division. Rounds towards zero. --- This corresponds to the @sdiv@ instruction in LLVM. -doSQuot :: IntValue -> IntValue -> Maybe IntValue -doSQuot v1 v2 - | zeroIshInt v2 = Nothing - | otherwise = Just $ intValue (intValueType v1) $ intToInt64 v1 `quot` intToInt64 v2 - --- | Signed integer division. Rounds towards zero. --- This corresponds to the @srem@ instruction in LLVM. -doSRem :: IntValue -> IntValue -> Maybe IntValue -doSRem v1 v2 - | zeroIshInt v2 = Nothing - | otherwise = Just $ intValue (intValueType v1) $ intToInt64 v1 `rem` intToInt64 v2 - --- | Minimum of two signed integers. -doSMin :: IntValue -> IntValue -> IntValue -doSMin v1 v2 = intValue (intValueType v1) $ intToInt64 v1 `min` intToInt64 v2 - --- | Minimum of two unsigned integers. -doUMin :: IntValue -> IntValue -> IntValue -doUMin v1 v2 = intValue (intValueType v1) $ intToWord64 v1 `min` intToWord64 v2 - --- | Maximum of two signed integers. -doSMax :: IntValue -> IntValue -> IntValue -doSMax v1 v2 = intValue (intValueType v1) $ intToInt64 v1 `max` intToInt64 v2 - --- | Maximum of two unsigned integers. -doUMax :: IntValue -> IntValue -> IntValue -doUMax v1 v2 = intValue (intValueType v1) $ intToWord64 v1 `max` intToWord64 v2 - --- | Left-shift. -doShl :: IntValue -> IntValue -> IntValue -doShl v1 v2 = intValue (intValueType v1) $ intToInt64 v1 `shift` intToInt v2 - --- | Logical right-shift, zero-extended. -doLShr :: IntValue -> IntValue -> IntValue -doLShr v1 v2 = intValue (intValueType v1) $ intToWord64 v1 `shift` negate (intToInt v2) - --- | Arithmetic right-shift, sign-extended. -doAShr :: IntValue -> IntValue -> IntValue -doAShr v1 v2 = intValue (intValueType v1) $ intToInt64 v1 `shift` negate (intToInt v2) - --- | Bitwise and. -doAnd :: IntValue -> IntValue -> IntValue -doAnd v1 v2 = intValue (intValueType v1) $ intToWord64 v1 .&. intToWord64 v2 - --- | Bitwise or. -doOr :: IntValue -> IntValue -> IntValue -doOr v1 v2 = intValue (intValueType v1) $ intToWord64 v1 .|. intToWord64 v2 - --- | Bitwise exclusive-or. -doXor :: IntValue -> IntValue -> IntValue -doXor v1 v2 = intValue (intValueType v1) $ intToWord64 v1 `xor` intToWord64 v2 - --- | Signed integer exponentatation. -doPow :: IntValue -> IntValue -> Maybe IntValue -doPow v1 v2 - | negativeIshInt v2 = Nothing - | otherwise = Just $ intValue (intValueType v1) $ intToInt64 v1 ^ intToInt64 v2 - --- | Apply a 'ConvOp' to an operand. Returns 'Nothing' if the --- application is mistyped. -doConvOp :: ConvOp -> PrimValue -> Maybe PrimValue -doConvOp (ZExt _ to) (IntValue v) = Just $ IntValue $ doZExt v to -doConvOp (SExt _ to) (IntValue v) = Just $ IntValue $ doSExt v to -doConvOp (FPConv _ to) (FloatValue v) = Just $ FloatValue $ doFPConv v to -doConvOp (FPToUI _ to) (FloatValue v) = Just $ IntValue $ doFPToUI v to -doConvOp (FPToSI _ to) (FloatValue v) = Just $ IntValue $ doFPToSI v to -doConvOp (UIToFP _ to) (IntValue v) = Just $ FloatValue $ doUIToFP v to -doConvOp (SIToFP _ to) (IntValue v) = Just $ FloatValue $ doSIToFP v to -doConvOp (IToB _) (IntValue v) = Just $ BoolValue $ intToInt64 v /= 0 -doConvOp (BToI to) (BoolValue v) = Just $ IntValue $ intValue to $ if v then 1 else 0::Int -doConvOp _ _ = Nothing - --- | Zero-extend the given integer value to the size of the given --- type. If the type is smaller than the given value, the result is a --- truncation. -doZExt :: IntValue -> IntType -> IntValue -doZExt (Int8Value x) t = intValue t $ toInteger (fromIntegral x :: Word8) -doZExt (Int16Value x) t = intValue t $ toInteger (fromIntegral x :: Word16) -doZExt (Int32Value x) t = intValue t $ toInteger (fromIntegral x :: Word32) -doZExt (Int64Value x) t = intValue t $ toInteger (fromIntegral x :: Word64) - --- | Sign-extend the given integer value to the size of the given --- type. If the type is smaller than the given value, the result is a --- truncation. -doSExt :: IntValue -> IntType -> IntValue -doSExt (Int8Value x) t = intValue t $ toInteger x -doSExt (Int16Value x) t = intValue t $ toInteger x -doSExt (Int32Value x) t = intValue t $ toInteger x -doSExt (Int64Value x) t = intValue t $ toInteger x - --- | Convert the former floating-point type to the latter. -doFPConv :: FloatValue -> FloatType -> FloatValue -doFPConv (Float32Value v) Float32 = Float32Value v -doFPConv (Float64Value v) Float32 = Float32Value $ fromRational $ toRational v -doFPConv (Float64Value v) Float64 = Float64Value v -doFPConv (Float32Value v) Float64 = Float64Value $ fromRational $ toRational v - --- | Convert a floating-point value to the nearest --- unsigned integer (rounding towards zero). -doFPToUI :: FloatValue -> IntType -> IntValue -doFPToUI v t = intValue t (truncate $ floatToDouble v :: Word64) - --- | Convert a floating-point value to the nearest --- signed integer (rounding towards zero). -doFPToSI :: FloatValue -> IntType -> IntValue -doFPToSI v t = intValue t (truncate $ floatToDouble v :: Word64) - --- | Convert an unsigned integer to a floating-point value. -doUIToFP :: IntValue -> FloatType -> FloatValue -doUIToFP v t = floatValue t $ intToWord64 v - --- | Convert a signed integer to a floating-point value. -doSIToFP :: IntValue -> FloatType -> FloatValue -doSIToFP v t = floatValue t $ intToInt64 v - --- | Apply a 'CmpOp' to an operand. Returns 'Nothing' if the --- application is mistyped. -doCmpOp :: CmpOp -> PrimValue -> PrimValue -> Maybe Bool -doCmpOp CmpEq{} v1 v2 = Just $ doCmpEq v1 v2 -doCmpOp CmpUlt{} (IntValue v1) (IntValue v2) = Just $ doCmpUlt v1 v2 -doCmpOp CmpUle{} (IntValue v1) (IntValue v2) = Just $ doCmpUle v1 v2 -doCmpOp CmpSlt{} (IntValue v1) (IntValue v2) = Just $ doCmpSlt v1 v2 -doCmpOp CmpSle{} (IntValue v1) (IntValue v2) = Just $ doCmpSle v1 v2 -doCmpOp FCmpLt{} (FloatValue v1) (FloatValue v2) = Just $ doFCmpLt v1 v2 -doCmpOp FCmpLe{} (FloatValue v1) (FloatValue v2) = Just $ doFCmpLe v1 v2 -doCmpOp CmpLlt{} (BoolValue v1) (BoolValue v2) = Just $ not v1 && v2 -doCmpOp CmpLle{} (BoolValue v1) (BoolValue v2) = Just $ not (v1 && not v2) -doCmpOp _ _ _ = Nothing - --- | Compare any two primtive values for exact equality. -doCmpEq :: PrimValue -> PrimValue -> Bool -doCmpEq v1 v2 = v1 == v2 - --- | Unsigned less than. -doCmpUlt :: IntValue -> IntValue -> Bool -doCmpUlt v1 v2 = intToWord64 v1 < intToWord64 v2 - --- | Unsigned less than or equal. -doCmpUle :: IntValue -> IntValue -> Bool -doCmpUle v1 v2 = intToWord64 v1 <= intToWord64 v2 - --- | Signed less than. -doCmpSlt :: IntValue -> IntValue -> Bool -doCmpSlt = (<) - --- | Signed less than or equal. -doCmpSle :: IntValue -> IntValue -> Bool -doCmpSle = (<=) - --- | Floating-point less than. -doFCmpLt :: FloatValue -> FloatValue -> Bool -doFCmpLt = (<) - --- | Floating-point less than or equal. -doFCmpLe :: FloatValue -> FloatValue -> Bool -doFCmpLe = (<=) - --- | Translate an 'IntValue' to 'Word64'. This is guaranteed to fit. -intToWord64 :: IntValue -> Word64 -intToWord64 (Int8Value v) = fromIntegral (fromIntegral v :: Word8) -intToWord64 (Int16Value v) = fromIntegral (fromIntegral v :: Word16) -intToWord64 (Int32Value v) = fromIntegral (fromIntegral v :: Word32) -intToWord64 (Int64Value v) = fromIntegral (fromIntegral v :: Word64) - --- | Translate an 'IntValue' to 'Int64'. This is guaranteed to fit. -intToInt64 :: IntValue -> Int64 -intToInt64 (Int8Value v) = fromIntegral v -intToInt64 (Int16Value v) = fromIntegral v -intToInt64 (Int32Value v) = fromIntegral v -intToInt64 (Int64Value v) = fromIntegral v - --- | Careful - there is no guarantee this will fit. -intToInt :: IntValue -> Int -intToInt = fromIntegral . intToInt64 - -floatToDouble :: FloatValue -> Double -floatToDouble (Float32Value v) = fromRational $ toRational v -floatToDouble (Float64Value v) = v - --- | The result type of a binary operator. -binOpType :: BinOp -> PrimType -binOpType (Add t _) = IntType t -binOpType (Sub t _) = IntType t -binOpType (Mul t _) = IntType t -binOpType (SDiv t) = IntType t -binOpType (SMod t) = IntType t -binOpType (SQuot t) = IntType t -binOpType (SRem t) = IntType t -binOpType (UDiv t) = IntType t -binOpType (UMod t) = IntType t -binOpType (SMin t) = IntType t -binOpType (UMin t) = IntType t -binOpType (FMin t) = FloatType t -binOpType (SMax t) = IntType t -binOpType (UMax t) = IntType t -binOpType (FMax t) = FloatType t -binOpType (Shl t) = IntType t -binOpType (LShr t) = IntType t -binOpType (AShr t) = IntType t -binOpType (And t) = IntType t -binOpType (Or t) = IntType t -binOpType (Xor t) = IntType t -binOpType (Pow t) = IntType t -binOpType (FPow t) = FloatType t -binOpType LogAnd = Bool -binOpType LogOr = Bool -binOpType (FAdd t) = FloatType t -binOpType (FSub t) = FloatType t -binOpType (FMul t) = FloatType t -binOpType (FDiv t) = FloatType t -binOpType (FMod t) = FloatType t - --- | The operand types of a comparison operator. -cmpOpType :: CmpOp -> PrimType -cmpOpType (CmpEq t) = t -cmpOpType (CmpSlt t) = IntType t -cmpOpType (CmpSle t) = IntType t -cmpOpType (CmpUlt t) = IntType t -cmpOpType (CmpUle t) = IntType t -cmpOpType (FCmpLt t) = FloatType t -cmpOpType (FCmpLe t) = FloatType t -cmpOpType CmpLlt = Bool -cmpOpType CmpLle = Bool - --- | The operand and result type of a unary operator. -unOpType :: UnOp -> PrimType -unOpType (SSignum t) = IntType t -unOpType (USignum t) = IntType t -unOpType Not = Bool -unOpType (Complement t) = IntType t -unOpType (Abs t) = IntType t -unOpType (FAbs t) = FloatType t - --- | The input and output types of a conversion operator. -convOpType :: ConvOp -> (PrimType, PrimType) -convOpType (ZExt from to) = (IntType from, IntType to) -convOpType (SExt from to) = (IntType from, IntType to) -convOpType (FPConv from to) = (FloatType from, FloatType to) -convOpType (FPToUI from to) = (FloatType from, IntType to) -convOpType (FPToSI from to) = (FloatType from, IntType to) -convOpType (UIToFP from to) = (IntType from, FloatType to) -convOpType (SIToFP from to) = (IntType from, FloatType to) -convOpType (IToB from) = (IntType from, Bool) -convOpType (BToI to) = (Bool, IntType to) - --- | A mapping from names of primitive functions to their parameter --- types, their result type, and a function for evaluating them. -primFuns :: M.Map String ([PrimType], PrimType, - [PrimValue] -> Maybe PrimValue) -primFuns = M.fromList - [ f32 "sqrt32" sqrt, f64 "sqrt64" sqrt - , f32 "log32" log, f64 "log64" log - , f32 "log10_32" (logBase 10), f64 "log10_64" (logBase 10) - , f32 "log2_32" (logBase 2), f64 "log2_64" (logBase 2) - , f32 "exp32" exp, f64 "exp64" exp - - , f32 "sin32" sin, f64 "sin64" sin - , f32 "sinh32" sinh, f64 "sinh64" sinh - , f32 "cos32" cos, f64 "cos64" cos - , f32 "cosh32" cosh, f64 "cosh64" cosh - , f32 "tan32" tan, f64 "tan64" tan - , f32 "tanh32" tanh, f64 "tanh64" tanh - , f32 "asin32" asin, f64 "asin64" asin - , f32 "asinh32" asinh, f64 "asinh64" asinh - , f32 "acos32" acos, f64 "acos64" acos - , f32 "acosh32" acosh, f64 "acosh64" acosh - , f32 "atan32" atan, f64 "atan64" atan - , f32 "atanh32" atanh, f64 "atanh64" atanh - - , f32 "round32" roundFloat, f64 "round64" roundDouble - , f32 "ceil32" ceilFloat, f64 "ceil64" ceilDouble - , f32 "floor32" floorFloat, f64 "floor64" floorDouble - , f32 "gamma32" tgammaf, f64 "gamma64" tgamma - , f32 "lgamma32" lgammaf, f64 "lgamma64" lgamma - - , i8 "clz8" $ IntValue . Int32Value . fromIntegral . countLeadingZeros - , i16 "clz16" $ IntValue . Int32Value . fromIntegral . countLeadingZeros - , i32 "clz32" $ IntValue . Int32Value . fromIntegral . countLeadingZeros - , i64 "clz64" $ IntValue . Int32Value . fromIntegral . countLeadingZeros - - , i8 "popc8" $ IntValue . Int32Value . fromIntegral . popCount - , i16 "popc16" $ IntValue . Int32Value . fromIntegral . popCount - , i32 "popc32" $ IntValue . Int32Value . fromIntegral . popCount - , i64 "popc64" $ IntValue . Int32Value . fromIntegral . popCount - - , ("mad_hi8", ([IntType Int8, IntType Int8, IntType Int8], IntType Int8, - \case - [IntValue (Int8Value a), IntValue (Int8Value b), IntValue (Int8Value c)] -> - Just $ IntValue . Int8Value $ mad_hi8 (Int8Value a) (Int8Value b) c - _ -> Nothing - )) - , ("mad_hi16", ([IntType Int16, IntType Int16, IntType Int16], IntType Int16, - \case - [IntValue (Int16Value a), IntValue (Int16Value b), IntValue (Int16Value c)] -> - Just $ IntValue . Int16Value $ mad_hi16 (Int16Value a) (Int16Value b) c - _ -> Nothing - )) - , ("mad_hi32", ([IntType Int32, IntType Int32, IntType Int32], IntType Int32, - \case - [IntValue (Int32Value a), IntValue (Int32Value b), IntValue (Int32Value c)] -> - Just $ IntValue . Int32Value $ mad_hi32 (Int32Value a) (Int32Value b) c - _ -> Nothing - )) - , ("mad_hi64", ([IntType Int64, IntType Int64, IntType Int64], IntType Int64, - \case - [IntValue (Int64Value a), IntValue (Int64Value b), IntValue (Int64Value c)] -> - Just $ IntValue . Int64Value $ mad_hi64 (Int64Value a) (Int64Value b) c - _ -> Nothing - )) - - , ("mul_hi8", ([IntType Int8, IntType Int8], IntType Int8, - \case - [IntValue (Int8Value a), IntValue (Int8Value b)] -> - Just $ IntValue . Int8Value $ mul_hi8 (Int8Value a) (Int8Value b) - _ -> Nothing - )) - , ("mul_hi16", ([IntType Int16, IntType Int16], IntType Int16, - \case - [IntValue (Int16Value a), IntValue (Int16Value b)] -> - Just $ IntValue . Int16Value $ mul_hi16 (Int16Value a) (Int16Value b) - _ -> Nothing - )) - , ("mul_hi32", ([IntType Int32, IntType Int32], IntType Int32, - \case - [IntValue (Int32Value a), IntValue (Int32Value b)] -> - Just $ IntValue . Int32Value $ mul_hi32 (Int32Value a) (Int32Value b) - _ -> Nothing - )) - , ("mul_hi64", ([IntType Int64, IntType Int64], IntType Int64, - \case - [IntValue (Int64Value a), IntValue (Int64Value b)] -> - Just $ IntValue . Int64Value $ mul_hi64 (Int64Value a) (Int64Value b) - _ -> Nothing - )) - - , ("atan2_32", - ([FloatType Float32, FloatType Float32], FloatType Float32, - \case - [FloatValue (Float32Value x), FloatValue (Float32Value y)] -> - Just $ FloatValue $ Float32Value $ atan2 x y - _ -> Nothing)) - , ("atan2_64", - ([FloatType Float64, FloatType Float64], FloatType Float64, - \case - [FloatValue (Float64Value x), FloatValue (Float64Value y)] -> - Just $ FloatValue $ Float64Value $ atan2 x y - _ -> Nothing)) - - , ("isinf32", - ([FloatType Float32], Bool, - \case - [FloatValue (Float32Value x)] -> Just $ BoolValue $ isInfinite x - _ -> Nothing)) - , ("isinf64", - ([FloatType Float64], Bool, - \case - [FloatValue (Float64Value x)] -> Just $ BoolValue $ isInfinite x - _ -> Nothing)) - - , ("isnan32", - ([FloatType Float32], Bool, - \case - [FloatValue (Float32Value x)] -> Just $ BoolValue $ isNaN x - _ -> Nothing)) - , ("isnan64", - ([FloatType Float64], Bool, - \case - [FloatValue (Float64Value x)] -> Just $ BoolValue $ isNaN x - _ -> Nothing)) - - , ("to_bits32", - ([FloatType Float32], IntType Int32, - \case - [FloatValue (Float32Value x)] -> - Just $ IntValue $ Int32Value $ fromIntegral $ floatToWord x - _ -> Nothing)) - , ("to_bits64", - ([FloatType Float64], IntType Int64, - \case - [FloatValue (Float64Value x)] -> - Just $ IntValue $ Int64Value $ fromIntegral $ doubleToWord x - _ -> Nothing)) - - , ("from_bits32", - ([IntType Int32], FloatType Float32, - \case - [IntValue (Int32Value x)] -> - Just $ FloatValue $ Float32Value $ wordToFloat $ fromIntegral x - _ -> Nothing)) - , ("from_bits64", - ([IntType Int64], FloatType Float64, - \case - [IntValue (Int64Value x)] -> - Just $ FloatValue $ Float64Value $ wordToDouble $ fromIntegral x - _ -> Nothing)) - - , f32_3 "lerp32" (\v0 v1 t -> v0 + (v1-v0)*max 0 (min 1 t)) - , f64_3 "lerp64" (\v0 v1 t -> v0 + (v1-v0)*max 0 (min 1 t)) - - , f32_3 "mad32" (\a b c -> a*b+c) - , f64_3 "mad64" (\a b c -> a*b+c) - - , f32_3 "fma32" (\a b c -> a*b+c) - , f64_3 "fma64" (\a b c -> a*b+c) - - ] - where i8 s f = (s, ([IntType Int8], IntType Int32, i8PrimFun f)) - i16 s f = (s, ([IntType Int16], IntType Int32, i16PrimFun f)) - i32 s f = (s, ([IntType Int32], IntType Int32, i32PrimFun f)) - i64 s f = (s, ([IntType Int64], IntType Int32, i64PrimFun f)) - f32 s f = (s, ([FloatType Float32], FloatType Float32, f32PrimFun f)) - f64 s f = (s, ([FloatType Float64], FloatType Float64, f64PrimFun f)) - f32_3 s f = (s, ([FloatType Float32,FloatType Float32,FloatType Float32], - FloatType Float32, f32PrimFun3 f)) - f64_3 s f = (s, ([FloatType Float64,FloatType Float64,FloatType Float64], - FloatType Float64, f64PrimFun3 f)) - - i8PrimFun f [IntValue (Int8Value x)] = - Just $ f x - i8PrimFun _ _ = Nothing - - i16PrimFun f [IntValue (Int16Value x)] = - Just $ f x - i16PrimFun _ _ = Nothing - - i32PrimFun f [IntValue (Int32Value x)] = - Just $ f x - i32PrimFun _ _ = Nothing - - i64PrimFun f [IntValue (Int64Value x)] = - Just $ f x - i64PrimFun _ _ = Nothing - - f32PrimFun f [FloatValue (Float32Value x)] = - Just $ FloatValue $ Float32Value $ f x - f32PrimFun _ _ = Nothing - - f64PrimFun f [FloatValue (Float64Value x)] = - Just $ FloatValue $ Float64Value $ f x - f64PrimFun _ _ = Nothing - - f32PrimFun3 f [FloatValue (Float32Value a), - FloatValue (Float32Value b), - FloatValue (Float32Value c)] = - Just $ FloatValue $ Float32Value $ f a b c - f32PrimFun3 _ _ = Nothing - - f64PrimFun3 f [FloatValue (Float64Value a), - FloatValue (Float64Value b), - FloatValue (Float64Value c)] = - Just $ FloatValue $ Float64Value $ f a b c - f64PrimFun3 _ _ = Nothing - --- | Is the given value kind of zero? -zeroIsh :: PrimValue -> Bool -zeroIsh (IntValue k) = zeroIshInt k -zeroIsh (FloatValue (Float32Value k)) = k == 0 -zeroIsh (FloatValue (Float64Value k)) = k == 0 -zeroIsh (BoolValue False) = True -zeroIsh _ = False - --- | Is the given value kind of one? -oneIsh :: PrimValue -> Bool -oneIsh (IntValue k) = oneIshInt k -oneIsh (FloatValue (Float32Value k)) = k == 1 -oneIsh (FloatValue (Float64Value k)) = k == 1 -oneIsh (BoolValue True) = True -oneIsh _ = False - --- | Is the given value kind of negative? -negativeIsh :: PrimValue -> Bool -negativeIsh (IntValue k) = negativeIshInt k -negativeIsh (FloatValue (Float32Value k)) = k < 0 -negativeIsh (FloatValue (Float64Value k)) = k < 0 -negativeIsh (BoolValue _) = False -negativeIsh Checked = False - --- | Is the given integer value kind of zero? -zeroIshInt :: IntValue -> Bool -zeroIshInt (Int8Value k) = k == 0 -zeroIshInt (Int16Value k) = k == 0 -zeroIshInt (Int32Value k) = k == 0 -zeroIshInt (Int64Value k) = k == 0 - --- | Is the given integer value kind of one? -oneIshInt :: IntValue -> Bool -oneIshInt (Int8Value k) = k == 1 -oneIshInt (Int16Value k) = k == 1 -oneIshInt (Int32Value k) = k == 1 -oneIshInt (Int64Value k) = k == 1 - --- | Is the given integer value kind of negative? -negativeIshInt :: IntValue -> Bool -negativeIshInt (Int8Value k) = k < 0 -negativeIshInt (Int16Value k) = k < 0 -negativeIshInt (Int32Value k) = k < 0 -negativeIshInt (Int64Value k) = k < 0 - --- | The size of a value of a given primitive type in bites. -primBitSize :: PrimType -> Int -primBitSize = (*8) . primByteSize - --- | The size of a value of a given primitive type in eight-bit bytes. -primByteSize :: Num a => PrimType -> a -primByteSize (IntType t) = intByteSize t -primByteSize (FloatType t) = floatByteSize t -primByteSize Bool = 1 -primByteSize Cert = 1 - --- | The size of a value of a given integer type in eight-bit bytes. -intByteSize :: Num a => IntType -> a -intByteSize Int8 = 1 -intByteSize Int16 = 2 -intByteSize Int32 = 4 -intByteSize Int64 = 8 - --- | The size of a value of a given floating-point type in eight-bit bytes. -floatByteSize :: Num a => FloatType -> a -floatByteSize Float32 = 4 -floatByteSize Float64 = 8 - --- | True if the given binary operator is commutative. -commutativeBinOp :: BinOp -> Bool -commutativeBinOp Add{} = True -commutativeBinOp FAdd{} = True -commutativeBinOp Mul{} = True -commutativeBinOp FMul{} = True -commutativeBinOp And{} = True -commutativeBinOp Or{} = True -commutativeBinOp Xor{} = True -commutativeBinOp LogOr{} = True -commutativeBinOp LogAnd{} = True -commutativeBinOp SMax{} = True -commutativeBinOp SMin{} = True -commutativeBinOp UMax{} = True -commutativeBinOp UMin{} = True -commutativeBinOp FMax{} = True -commutativeBinOp FMin{} = True -commutativeBinOp _ = False - --- Prettyprinting instances - -instance Pretty BinOp where - ppr (Add t OverflowWrap) = taggedI "add" t - ppr (Add t OverflowUndef) = taggedI "add_nw" t - ppr (Sub t OverflowWrap) = taggedI "sub" t - ppr (Sub t OverflowUndef) = taggedI "sub_nw" t - ppr (Mul t OverflowWrap) = taggedI "mul" t - ppr (Mul t OverflowUndef) = taggedI "mul_nw" t - ppr (FAdd t) = taggedF "fadd" t - ppr (FSub t) = taggedF "fsub" t - ppr (FMul t) = taggedF "fmul" t - ppr (UDiv t) = taggedI "udiv" t - ppr (UMod t) = taggedI "umod" t - ppr (SDiv t) = taggedI "sdiv" t - ppr (SMod t) = taggedI "smod" t - ppr (SQuot t) = taggedI "squot" t - ppr (SRem t) = taggedI "srem" t - ppr (FDiv t) = taggedF "fdiv" t - ppr (FMod t) = taggedF "fmod" t - ppr (SMin t) = taggedI "smin" t - ppr (UMin t) = taggedI "umin" t - ppr (FMin t) = taggedF "fmin" t - ppr (SMax t) = taggedI "smax" t - ppr (UMax t) = taggedI "umax" t - ppr (FMax t) = taggedF "fmax" t - ppr (Shl t) = taggedI "shl" t - ppr (LShr t) = taggedI "lshr" t - ppr (AShr t) = taggedI "ashr" t - ppr (And t) = taggedI "and" t - ppr (Or t) = taggedI "or" t - ppr (Xor t) = taggedI "xor" t - ppr (Pow t) = taggedI "pow" t - ppr (FPow t) = taggedF "fpow" t - ppr LogAnd = text "logand" - ppr LogOr = text "logor" - -instance Pretty CmpOp where - ppr (CmpEq t) = text "eq_" <> ppr t - ppr (CmpUlt t) = taggedI "ult" t - ppr (CmpUle t) = taggedI "ule" t - ppr (CmpSlt t) = taggedI "slt" t - ppr (CmpSle t) = taggedI "sle" t - ppr (FCmpLt t) = taggedF "lt" t - ppr (FCmpLe t) = taggedF "le" t - ppr CmpLlt = text "llt" - ppr CmpLle = text "lle" - -instance Pretty ConvOp where - ppr op = convOp (convOpFun op) from to - where (from, to) = convOpType op - -instance Pretty UnOp where - ppr Not = text "not" - ppr (Abs t) = taggedI "abs" t - ppr (FAbs t) = taggedF "fabs" t - ppr (SSignum t) = taggedI "ssignum" t - ppr (USignum t) = taggedI "usignum" t - ppr (Complement t) = taggedI "complement" t - --- | The human-readable name for a 'ConvOp'. This is used to expose --- the 'ConvOp' in the @intrinsics@ module of a Futhark program. -convOpFun :: ConvOp -> String -convOpFun ZExt{} = "zext" -convOpFun SExt{} = "sext" -convOpFun FPConv{} = "fpconv" -convOpFun FPToUI{} = "fptoui" -convOpFun FPToSI{} = "fptosi" -convOpFun UIToFP{} = "uitofp" -convOpFun SIToFP{} = "sitofp" -convOpFun IToB{} = "itob" -convOpFun BToI{} = "btoi" - -taggedI :: String -> IntType -> Doc -taggedI s Int8 = text $ s ++ "8" -taggedI s Int16 = text $ s ++ "16" -taggedI s Int32 = text $ s ++ "32" -taggedI s Int64 = text $ s ++ "64" - -taggedF :: String -> FloatType -> Doc -taggedF s Float32 = text $ s ++ "32" -taggedF s Float64 = text $ s ++ "64" - -convOp :: (Pretty from, Pretty to) => String -> from -> to -> Doc -convOp s from to = text s <> text "_" <> ppr from <> text "_" <> ppr to - --- | True if signed. Only makes a difference for integer types. -prettySigned :: Bool -> PrimType -> String -prettySigned True (IntType it) = 'u' : drop 1 (pretty it) -prettySigned _ t = pretty t - -mul_hi8 :: IntValue -> IntValue -> Int8 -mul_hi8 a b = - let a' = intToWord64 a - b' = intToWord64 b - in fromIntegral (shiftR (a' * b') 8) - -mul_hi16 :: IntValue -> IntValue -> Int16 -mul_hi16 a b = - let a' = intToWord64 a - b' = intToWord64 b - in fromIntegral (shiftR (a' * b') 16) - -mul_hi32 :: IntValue -> IntValue -> Int32 -mul_hi32 a b = - let a' = intToWord64 a - b' = intToWord64 b - in fromIntegral (shiftR (a' * b') 32) - -mul_hi64 :: IntValue -> IntValue -> Int64 -mul_hi64 a b = - let a' = (toInteger . intToWord64) a - b' = (toInteger . intToWord64) b - in fromIntegral (shiftR (a' * b') 64) - -mad_hi8 :: IntValue -> IntValue -> Int8 -> Int8 -mad_hi8 a b c = mul_hi8 a b + c - -mad_hi16 :: IntValue -> IntValue -> Int16 -> Int16 -mad_hi16 a b c = mul_hi16 a b + c - -mad_hi32 :: IntValue -> IntValue -> Int32 -> Int32 -mad_hi32 a b c = mul_hi32 a b + c - -mad_hi64 :: IntValue -> IntValue -> Int64 -> Int64 -mad_hi64 a b c = mul_hi64 a b + c diff --git a/src/Futhark/Representation/Ranges.hs b/src/Futhark/Representation/Ranges.hs deleted file mode 100644 --- a/src/Futhark/Representation/Ranges.hs +++ /dev/null @@ -1,183 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} --- | A representation where all bindings are annotated with range --- information. -module Futhark.Representation.Ranges - ( -- * The Lore definition - Ranges - , module Futhark.Representation.AST.Attributes.Ranges - -- * Module re-exports - , module Futhark.Representation.AST.Attributes - , module Futhark.Representation.AST.Traversals - , module Futhark.Representation.AST.Pretty - , module Futhark.Representation.AST.Syntax - -- * Adding ranges - , addRangesToPattern - , mkRangedBody - , mkPatternRanges - , mkBodyRanges - -- * Removing ranges - , removeProgRanges - , removeExpRanges - , removeBodyRanges - , removeStmRanges - , removeLambdaRanges - , removePatternRanges - ) -where - -import Control.Monad.Identity -import Control.Monad.Reader - -import Futhark.Representation.AST.Syntax -import Futhark.Representation.AST.Attributes -import Futhark.Representation.AST.Attributes.Aliases -import Futhark.Representation.AST.Attributes.Ranges -import Futhark.Representation.AST.Traversals -import Futhark.Representation.AST.Pretty -import Futhark.Analysis.Rephrase -import qualified Futhark.Util.Pretty as PP - --- | The lore for the basic representation. -data Ranges lore - -instance (Annotations lore, CanBeRanged (Op lore)) => - Annotations (Ranges lore) where - type LetAttr (Ranges lore) = (Range, LetAttr lore) - type ExpAttr (Ranges lore) = ExpAttr lore - type BodyAttr (Ranges lore) = ([Range], BodyAttr lore) - type FParamAttr (Ranges lore) = FParamAttr lore - type LParamAttr (Ranges lore) = LParamAttr lore - type RetType (Ranges lore) = RetType lore - type BranchType (Ranges lore) = BranchType lore - type Op (Ranges lore) = OpWithRanges (Op lore) - -withoutRanges :: (HasScope (Ranges lore) m, Monad m) => - ReaderT (Scope lore) m a -> - m a -withoutRanges m = do - scope <- asksScope $ fmap unRange - runReaderT m scope - where unRange :: NameInfo (Ranges lore) -> NameInfo lore - unRange (LetInfo (_, x)) = LetInfo x - unRange (FParamInfo x) = FParamInfo x - unRange (LParamInfo x) = LParamInfo x - unRange (IndexInfo x) = IndexInfo x - -instance (Attributes lore, CanBeRanged (Op lore)) => - Attributes (Ranges lore) where - expTypesFromPattern = - withoutRanges . expTypesFromPattern . removePatternRanges - -instance RangeOf (Range, attr) where - rangeOf = fst - -instance RangesOf ([Range], attr) where - rangesOf = fst - -instance PrettyAnnot (PatElemT attr) => - PrettyAnnot (PatElemT (Range, attr)) where - - ppAnnot patelem = - range_annot <> inner_annot - where range_annot = - case fst . patElemAttr $ patelem of - (Nothing, Nothing) -> Nothing - range -> - Just $ PP.oneLine $ - PP.text "-- " <> PP.ppr (patElemName patelem) <> PP.text " range: " <> - PP.ppr range - inner_annot = ppAnnot $ fmap snd patelem - - -instance (PrettyLore lore, CanBeRanged (Op lore)) => PrettyLore (Ranges lore) where - ppExpLore attr = ppExpLore attr . removeExpRanges - -removeRanges :: CanBeRanged (Op lore) => Rephraser Identity (Ranges lore) lore -removeRanges = Rephraser { rephraseExpLore = return - , rephraseLetBoundLore = return . snd - , rephraseBodyLore = return . snd - , rephraseFParamLore = return - , rephraseLParamLore = return - , rephraseRetType = return - , rephraseBranchType = return - , rephraseOp = return . removeOpRanges - } - -removeProgRanges :: CanBeRanged (Op lore) => - Prog (Ranges lore) -> Prog lore -removeProgRanges = runIdentity . rephraseProg removeRanges - -removeExpRanges :: CanBeRanged (Op lore) => - Exp (Ranges lore) -> Exp lore -removeExpRanges = runIdentity . rephraseExp removeRanges - -removeBodyRanges :: CanBeRanged (Op lore) => - Body (Ranges lore) -> Body lore -removeBodyRanges = runIdentity . rephraseBody removeRanges - -removeStmRanges :: CanBeRanged (Op lore) => - Stm (Ranges lore) -> Stm lore -removeStmRanges = runIdentity . rephraseStm removeRanges - -removeLambdaRanges :: CanBeRanged (Op lore) => - Lambda (Ranges lore) -> Lambda lore -removeLambdaRanges = runIdentity . rephraseLambda removeRanges - -removePatternRanges :: PatternT (Range, a) - -> PatternT a -removePatternRanges = runIdentity . rephrasePattern (return . snd) - -addRangesToPattern :: (Attributes lore, CanBeRanged (Op lore)) => - Pattern lore -> Exp (Ranges lore) - -> Pattern (Ranges lore) -addRangesToPattern pat e = - uncurry Pattern $ mkPatternRanges pat e - -mkRangedBody :: BodyAttr lore -> Stms (Ranges lore) -> Result - -> Body (Ranges lore) -mkRangedBody innerlore bnds res = - Body (mkBodyRanges bnds res, innerlore) bnds res - -mkPatternRanges :: (Attributes lore, CanBeRanged (Op lore)) => - Pattern lore - -> Exp (Ranges lore) - -> ([PatElemT (Range, LetAttr lore)], - [PatElemT (Range, LetAttr lore)]) -mkPatternRanges pat e = - (map (`addRanges` unknownRange) $ patternContextElements pat, - zipWith addRanges (patternValueElements pat) ranges) - where addRanges patElem range = - let innerlore = patElemAttr patElem - in patElem `setPatElemLore` (range, innerlore) - ranges = expRanges e - -mkBodyRanges :: Stms lore -> Result -> [Range] -mkBodyRanges bnds = map $ removeUnknownBounds . rangeOf - where boundInBnds = - foldMap (namesFromList . patternNames . stmPattern) bnds - removeUnknownBounds (lower,upper) = - (removeUnknownBound lower, - removeUnknownBound upper) - removeUnknownBound (Just bound) - | freeIn bound `namesIntersect` boundInBnds = Nothing - | otherwise = Just bound - removeUnknownBound Nothing = - Nothing - --- It is convenient for a wrapped aliased lore to also be aliased. - -instance AliasesOf attr => AliasesOf ([Range], attr) where - aliasesOf = aliasesOf . snd - -instance AliasesOf attr => AliasesOf (Range, attr) where - aliasesOf = aliasesOf . snd - -instance (Aliased lore, CanBeRanged (Op lore), - AliasedOp (OpWithRanges (Op lore))) => Aliased (Ranges lore) where - bodyAliases = bodyAliases . removeBodyRanges - consumedInBody = consumedInBody . removeBodyRanges diff --git a/src/Futhark/Representation/SOACS.hs b/src/Futhark/Representation/SOACS.hs deleted file mode 100644 --- a/src/Futhark/Representation/SOACS.hs +++ /dev/null @@ -1,81 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} --- | A simple representation with SOACs and nested parallelism. -module Futhark.Representation.SOACS - ( -- * The Lore definition - SOACS - -- * Syntax types - , Body - , Stm - , Pattern - , Exp - , Lambda - , FParam - , LParam - , RetType - , PatElem - -- * Module re-exports - , module Futhark.Representation.AST.Attributes - , module Futhark.Representation.AST.Traversals - , module Futhark.Representation.AST.Pretty - , module Futhark.Representation.AST.Syntax - , module Futhark.Representation.SOACS.SOAC - , AST.LambdaT(Lambda) - , AST.BodyT(Body) - , AST.PatternT(Pattern) - , AST.PatElemT(PatElem) - ) -where - -import qualified Futhark.Representation.AST.Syntax as AST -import Futhark.Representation.AST.Syntax - hiding (Exp, Body, Stm, - Pattern, Lambda, FParam, LParam, RetType, PatElem) -import Futhark.Representation.SOACS.SOAC -import Futhark.Representation.AST.Attributes -import Futhark.Representation.AST.Traversals -import Futhark.Representation.AST.Pretty -import Futhark.Binder -import Futhark.Construct -import qualified Futhark.TypeCheck as TypeCheck - --- This module could be written much nicer if Haskell had functors --- like Standard ML. Instead, we have to abuse the namespace/module --- system. - --- | The lore for the basic representation. -data SOACS - -instance Annotations SOACS where - type Op SOACS = SOAC SOACS - -instance Attributes SOACS where - expTypesFromPattern = return . expExtTypesFromPattern - -type Exp = AST.Exp SOACS -type Body = AST.Body SOACS -type Stm = AST.Stm SOACS -type Pattern = AST.Pattern SOACS -type Lambda = AST.Lambda SOACS -type FParam = AST.FParam SOACS -type LParam = AST.LParam SOACS -type RetType = AST.RetType SOACS -type PatElem = AST.PatElem SOACS - -instance TypeCheck.CheckableOp SOACS where - checkOp = typeCheckSOAC - -instance TypeCheck.Checkable SOACS where - -instance Bindable SOACS where - mkBody = AST.Body () - mkExpPat ctx val _ = basicPattern ctx val - mkExpAttr _ _ = () - mkLetNames = simpleMkLetNames - -instance BinderOps SOACS where - mkExpAttrB = bindableMkExpAttrB - mkBodyB = bindableMkBodyB - mkLetNamesB = bindableMkLetNamesB - -instance PrettyLore SOACS where diff --git a/src/Futhark/Representation/SOACS/SOAC.hs b/src/Futhark/Representation/SOACS/SOAC.hs deleted file mode 100644 --- a/src/Futhark/Representation/SOACS/SOAC.hs +++ /dev/null @@ -1,763 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ConstraintKinds #-} -module Futhark.Representation.SOACS.SOAC - ( SOAC(..) - , StreamForm(..) - , ScremaForm(..) - , HistOp(..) - , Scan(..) - , scanResults - , singleScan - , Reduce(..) - , redResults - , singleReduce - - -- * Utility - , getStreamOrder - , getStreamAccums - , scremaType - , soacType - - , typeCheckSOAC - - , mkIdentityLambda - , isIdentityLambda - , nilFn - , scanomapSOAC - , redomapSOAC - , scanSOAC - , reduceSOAC - , mapSOAC - , isScanomapSOAC - , isRedomapSOAC - , isScanSOAC - , isReduceSOAC - , isMapSOAC - - , ppScrema - , ppHist - - -- * Generic traversal - , SOACMapper(..) - , identitySOACMapper - , mapSOACM - ) - where - -import Control.Monad.State.Strict -import Control.Monad.Writer -import Control.Monad.Identity -import qualified Data.Map.Strict as M -import Data.Maybe -import Data.List (intersperse) - -import Futhark.Representation.AST -import qualified Futhark.Analysis.Alias as Alias -import qualified Futhark.Util.Pretty as PP -import Futhark.Util.Pretty (ppr, Doc, Pretty, parens, comma, (), (<+>), commasep, text) -import Futhark.Representation.AST.Attributes.Aliases -import Futhark.Transform.Substitute -import Futhark.Transform.Rename -import Futhark.Optimise.Simplify.Lore -import Futhark.Representation.Ranges (Ranges, removeLambdaRanges) -import Futhark.Representation.AST.Attributes.Ranges -import Futhark.Representation.Aliases (Aliases, removeLambdaAliases) -import qualified Futhark.Analysis.SymbolTable as ST -import Futhark.Analysis.PrimExp.Convert -import qualified Futhark.TypeCheck as TC -import Futhark.Analysis.Metrics -import qualified Futhark.Analysis.Range as Range -import Futhark.Construct -import Futhark.Util (maybeNth, chunks) - -data SOAC lore = - Stream SubExp (StreamForm lore) (Lambda lore) [VName] - | Scatter SubExp (Lambda lore) [VName] [(SubExp, Int, VName)] - -- Scatter - -- - -- - -- - -- is the length of each index array and value array, since they - -- all must be the same length for any fusion to make sense. If you have a - -- list of index-value array pairs of different sizes, you need to use - -- multiple writes instead. - -- - -- The lambda body returns the output in this manner: - -- - -- [index_0, index_1, ..., index_n, value_0, value_1, ..., value_n] - -- - -- This must be consistent along all Scatter-related optimisations. - | Hist SubExp [HistOp lore] (Lambda lore) [VName] - -- Hist - -- - -- The first SubExp is the length of the input arrays. The first - -- list describes the operations to perform. The 'Lambda' is the - -- bucket function. Finally comes the input images. - | Screma SubExp (ScremaForm lore) [VName] - -- ^ A combination of scan, reduction, and map. The first - -- 'SubExp' is the size of the input arrays. The first - -- 'Lambda'/'SubExp' pair is for scan and its neutral elements. - -- The second is for the reduction. The final lambda is for the - -- map part, and finally comes the input arrays. - deriving (Eq, Ord, Show) - -data HistOp lore = HistOp { histWidth :: SubExp - , histRaceFactor :: SubExp - -- ^ Race factor @RF@ means that only @1/RF@ - -- bins are used. - , histDest :: [VName] - , histNeutral :: [SubExp] - , histOp :: Lambda lore - } - deriving (Eq, Ord, Show) - -data StreamForm lore = - Parallel StreamOrd Commutativity (Lambda lore) [SubExp] - | Sequential [SubExp] - deriving (Eq, Ord, Show) - --- | The essential parts of a 'Screma' factored out (everything --- except the input arrays). -data ScremaForm lore = ScremaForm - [Scan lore] - [Reduce lore] - (Lambda lore) - deriving (Eq, Ord, Show) - -singleBinOp :: Bindable lore => [Lambda lore] -> Lambda lore -singleBinOp lams = - Lambda { lambdaParams = concatMap xParams lams ++ concatMap yParams lams - , lambdaReturnType = concatMap lambdaReturnType lams - , lambdaBody = mkBody (mconcat (map (bodyStms . lambdaBody) lams)) - (concatMap (bodyResult . lambdaBody) lams) - } - where xParams lam = take (length (lambdaReturnType lam)) (lambdaParams lam) - yParams lam = drop (length (lambdaReturnType lam)) (lambdaParams lam) - -data Scan lore = Scan { scanLambda :: Lambda lore - , scanNeutral :: [SubExp] - } - deriving (Eq, Ord, Show) - --- | How many reduction results are produced by these 'Scan's? -scanResults :: [Scan lore] -> Int -scanResults = sum . map (length . scanNeutral) - --- | Combine multiple scan operators to a single operator. -singleScan :: Bindable lore => [Scan lore] -> Scan lore -singleScan scans = - let scan_nes = concatMap scanNeutral scans - scan_lam = singleBinOp $ map scanLambda scans - in Scan scan_lam scan_nes - -data Reduce lore = Reduce { redComm :: Commutativity - , redLambda :: Lambda lore - , redNeutral :: [SubExp] - } - deriving (Eq, Ord, Show) - --- | How many reduction results are produced by these 'Reduce's? -redResults :: [Reduce lore] -> Int -redResults = sum . map (length . redNeutral) - --- | Combine multiple reduction operators to a single operator. -singleReduce :: Bindable lore => [Reduce lore] -> Reduce lore -singleReduce reds = - let red_nes = concatMap redNeutral reds - red_lam = singleBinOp $ map redLambda reds - in Reduce (mconcat (map redComm reds)) red_lam red_nes - -scremaType :: SubExp -> ScremaForm lore -> [Type] -scremaType w (ScremaForm scans reds map_lam) = - scan_tps ++ red_tps ++ map (`arrayOfRow` w) map_tps - where scan_tps = map (`arrayOfRow` w) $ - concatMap (lambdaReturnType . scanLambda) scans - red_tps = concatMap (lambdaReturnType . redLambda) reds - map_tps = drop (length scan_tps + length red_tps) $ lambdaReturnType map_lam - --- | Construct a lambda that takes parameters of the given types and --- simply returns them unchanged. -mkIdentityLambda :: (Bindable lore, MonadFreshNames m) => - [Type] -> m (Lambda lore) -mkIdentityLambda ts = do - params <- mapM (newParam "x") ts - return Lambda { lambdaParams = params - , lambdaBody = mkBody mempty $ map (Var . paramName) params - , lambdaReturnType = ts } - --- | Is the given lambda an identity lambda? -isIdentityLambda :: Lambda lore -> Bool -isIdentityLambda lam = bodyResult (lambdaBody lam) == - map (Var . paramName) (lambdaParams lam) - --- | A lambda with no parameters that returns no values. -nilFn :: Bindable lore => Lambda lore -nilFn = Lambda mempty (mkBody mempty mempty) mempty - -scanomapSOAC :: [Scan lore] -> Lambda lore -> ScremaForm lore -scanomapSOAC scans = ScremaForm scans [] - -redomapSOAC :: [Reduce lore] -> Lambda lore -> ScremaForm lore -redomapSOAC = ScremaForm [] - -scanSOAC :: (Bindable lore, MonadFreshNames m) => - [Scan lore] -> m (ScremaForm lore) -scanSOAC scans = scanomapSOAC scans <$> mkIdentityLambda ts - where ts = concatMap (lambdaReturnType . scanLambda) scans - -reduceSOAC :: (Bindable lore, MonadFreshNames m) => - [Reduce lore] -> m (ScremaForm lore) -reduceSOAC reds = redomapSOAC reds <$> mkIdentityLambda ts - where ts = concatMap (lambdaReturnType . redLambda) reds - -mapSOAC :: Lambda lore -> ScremaForm lore -mapSOAC = ScremaForm [] [] - -isScanomapSOAC :: ScremaForm lore -> Maybe ([Scan lore], Lambda lore) -isScanomapSOAC (ScremaForm scans reds map_lam) = do - guard $ null reds - guard $ not $ null scans - return (scans, map_lam) - -isScanSOAC :: ScremaForm lore -> Maybe [Scan lore] -isScanSOAC form = do (scans, map_lam) <- isScanomapSOAC form - guard $ isIdentityLambda map_lam - return scans - -isRedomapSOAC :: ScremaForm lore -> Maybe ([Reduce lore], Lambda lore) -isRedomapSOAC (ScremaForm scans reds map_lam) = do - guard $ null scans - guard $ not $ null reds - return (reds, map_lam) - -isReduceSOAC :: ScremaForm lore -> Maybe [Reduce lore] -isReduceSOAC form = do (reds, map_lam) <- isRedomapSOAC form - guard $ isIdentityLambda map_lam - return reds - -isMapSOAC :: ScremaForm lore -> Maybe (Lambda lore) -isMapSOAC (ScremaForm scans reds map_lam) = do - guard $ null scans - guard $ null reds - return map_lam - --- | Like 'Mapper', but just for 'SOAC's. -data SOACMapper flore tlore m = SOACMapper { - mapOnSOACSubExp :: SubExp -> m SubExp - , mapOnSOACLambda :: Lambda flore -> m (Lambda tlore) - , mapOnSOACVName :: VName -> m VName - } - --- | A mapper that simply returns the SOAC verbatim. -identitySOACMapper :: Monad m => SOACMapper lore lore m -identitySOACMapper = SOACMapper { mapOnSOACSubExp = return - , mapOnSOACLambda = return - , mapOnSOACVName = return - } - --- | Map a monadic action across the immediate children of a --- SOAC. The mapping does not descend recursively into subexpressions --- and is done left-to-right. -mapSOACM :: (Applicative m, Monad m) => - SOACMapper flore tlore m -> SOAC flore -> m (SOAC tlore) -mapSOACM tv (Stream size form lam arrs) = - Stream <$> mapOnSOACSubExp tv size <*> - mapOnStreamForm form <*> mapOnSOACLambda tv lam <*> - mapM (mapOnSOACVName tv) arrs - where mapOnStreamForm (Parallel o comm lam0 acc) = - Parallel <$> pure o <*> pure comm <*> - mapOnSOACLambda tv lam0 <*> - mapM (mapOnSOACSubExp tv) acc - mapOnStreamForm (Sequential acc) = - Sequential <$> mapM (mapOnSOACSubExp tv) acc -mapSOACM tv (Scatter len lam ivs as) = - Scatter - <$> mapOnSOACSubExp tv len - <*> mapOnSOACLambda tv lam - <*> mapM (mapOnSOACVName tv) ivs - <*> mapM (\(aw,an,a) -> (,,) <$> mapOnSOACSubExp tv aw <*> - pure an <*> mapOnSOACVName tv a) as -mapSOACM tv (Hist len ops bucket_fun imgs) = - Hist - <$> mapOnSOACSubExp tv len - <*> mapM (\(HistOp e rf arrs nes op) -> - HistOp <$> mapOnSOACSubExp tv e - <*> mapOnSOACSubExp tv rf - <*> mapM (mapOnSOACVName tv) arrs - <*> mapM (mapOnSOACSubExp tv) nes - <*> mapOnSOACLambda tv op) ops - <*> mapOnSOACLambda tv bucket_fun - <*> mapM (mapOnSOACVName tv) imgs -mapSOACM tv (Screma w (ScremaForm scans reds map_lam) arrs) = - Screma <$> mapOnSOACSubExp tv w <*> - (ScremaForm <$> - forM scans (\(Scan red_lam red_nes) -> - Scan <$> mapOnSOACLambda tv red_lam <*> - mapM (mapOnSOACSubExp tv) red_nes) <*> - forM reds (\(Reduce comm red_lam red_nes) -> - Reduce comm <$> mapOnSOACLambda tv red_lam <*> - mapM (mapOnSOACSubExp tv) red_nes) <*> - mapOnSOACLambda tv map_lam) - <*> mapM (mapOnSOACVName tv) arrs - -instance Attributes lore => FreeIn (SOAC lore) where - freeIn' = flip execState mempty . mapSOACM free - where walk f x = modify (<>f x) >> return x - free = SOACMapper { mapOnSOACSubExp = walk freeIn' - , mapOnSOACLambda = walk freeIn' - , mapOnSOACVName = walk freeIn' - } - -instance Attributes lore => Substitute (SOAC lore) where - substituteNames subst = - runIdentity . mapSOACM substitute - where substitute = - SOACMapper { mapOnSOACSubExp = return . substituteNames subst - , mapOnSOACLambda = return . substituteNames subst - , mapOnSOACVName = return . substituteNames subst - } - -instance Attributes lore => Rename (SOAC lore) where - rename = mapSOACM renamer - where renamer = SOACMapper rename rename rename - -soacType :: SOAC lore -> [Type] -soacType (Stream outersize form lam _) = - map (substNamesInType substs) rtp - where nms = map paramName $ take (1 + length accs) params - substs = M.fromList $ zip nms (outersize:accs) - Lambda params _ rtp = lam - accs = case form of - Parallel _ _ _ acc -> acc - Sequential acc -> acc -soacType (Scatter _w lam _ivs as) = - zipWith arrayOfRow val_ts ws - where val_ts = concatMap (take 1) $ chunks ns $ - drop (sum ns) $ lambdaReturnType lam - (ws, ns, _) = unzip3 as -soacType (Hist _len ops _bucket_fun _imgs) = do - op <- ops - map (`arrayOfRow` histWidth op) (lambdaReturnType $ histOp op) -soacType (Screma w form _arrs) = - scremaType w form - -instance TypedOp (SOAC lore) where - opType = pure . staticShapes . soacType - -instance (Attributes lore, Aliased lore) => AliasedOp (SOAC lore) where - opAliases = map (const mempty) . soacType - - -- Only map functions can consume anything. The operands to scan - -- and reduce functions are always considered "fresh". - consumedInOp (Screma _ (ScremaForm _ _ map_lam) arrs) = - mapNames consumedArray $ consumedByLambda map_lam - where consumedArray v = fromMaybe v $ lookup v params_to_arrs - params_to_arrs = zip (map paramName $ lambdaParams map_lam) arrs - consumedInOp (Stream _ form lam arrs) = - namesFromList $ subExpVars $ - case form of Sequential accs -> - map (consumedArray accs) $ namesToList $ consumedByLambda lam - Parallel _ _ _ accs -> - map (consumedArray accs) $ namesToList $ consumedByLambda lam - where consumedArray accs v = fromMaybe (Var v) $ lookup v $ paramsToInput accs - -- Drop the chunk parameter, which cannot alias anything. - paramsToInput accs = zip - (map paramName $ drop 1 $ lambdaParams lam) - (accs++map Var arrs) - consumedInOp (Scatter _ _ _ as) = - namesFromList $ map (\(_, _, a) -> a) as - consumedInOp (Hist _ ops _ _) = - namesFromList $ concatMap histDest ops - -mapHistOp :: (Lambda flore -> Lambda tlore) - -> HistOp flore -> HistOp tlore -mapHistOp f (HistOp w rf dests nes lam) = - HistOp w rf dests nes $ f lam - -instance (Attributes lore, - Attributes (Aliases lore), - CanBeAliased (Op lore)) => CanBeAliased (SOAC lore) where - type OpWithAliases (SOAC lore) = SOAC (Aliases lore) - - addOpAliases (Stream size form lam arr) = - Stream size (analyseStreamForm form) - (Alias.analyseLambda lam) arr - where analyseStreamForm (Parallel o comm lam0 acc) = - Parallel o comm (Alias.analyseLambda lam0) acc - analyseStreamForm (Sequential acc) = Sequential acc - addOpAliases (Scatter len lam ivs as) = - Scatter len (Alias.analyseLambda lam) ivs as - addOpAliases (Hist len ops bucket_fun imgs) = - Hist len (map (mapHistOp Alias.analyseLambda) ops) - (Alias.analyseLambda bucket_fun) imgs - addOpAliases (Screma w (ScremaForm scans reds map_lam) arrs) = - Screma w (ScremaForm - (map onScan scans) - (map onRed reds) - (Alias.analyseLambda map_lam)) - arrs - where onRed red = red { redLambda = Alias.analyseLambda $ redLambda red } - onScan scan = scan { scanLambda = Alias.analyseLambda $ scanLambda scan } - - removeOpAliases = runIdentity . mapSOACM remove - where remove = SOACMapper return (return . removeLambdaAliases) return - -instance Attributes lore => IsOp (SOAC lore) where - safeOp _ = False - cheapOp _ = True - -substNamesInType :: M.Map VName SubExp -> Type -> Type -substNamesInType _ tp@(Prim _) = tp -substNamesInType _ (Mem space) = Mem space -substNamesInType subs (Array btp shp u) = - let shp' = Shape $ map (substNamesInSubExp subs) (shapeDims shp) - in Array btp shp' u - -substNamesInSubExp :: M.Map VName SubExp -> SubExp -> SubExp -substNamesInSubExp _ e@(Constant _) = e -substNamesInSubExp subs (Var idd) = - M.findWithDefault (Var idd) idd subs - -instance (Ranged inner) => RangedOp (SOAC inner) where - opRanges op = replicate (length $ soacType op) unknownRange - -instance (Attributes lore, CanBeRanged (Op lore)) => CanBeRanged (SOAC lore) where - type OpWithRanges (SOAC lore) = SOAC (Ranges lore) - - removeOpRanges = runIdentity . mapSOACM remove - where remove = SOACMapper return (return . removeLambdaRanges) return - addOpRanges (Stream w form lam arr) = - Stream w - (Range.runRangeM $ analyseStreamForm form) - (Range.runRangeM $ Range.analyseLambda lam) - arr - where analyseStreamForm (Sequential acc) = - return $ Sequential acc - analyseStreamForm (Parallel o comm lam0 acc) = do - lam0' <- Range.analyseLambda lam0 - return $ Parallel o comm lam0' acc - addOpRanges (Scatter len lam ivs as) = - Scatter len (Range.runRangeM $ Range.analyseLambda lam) ivs as - addOpRanges (Hist len ops bucket_fun imgs) = - Hist len (map (mapHistOp $ Range.runRangeM . Range.analyseLambda) ops) - (Range.runRangeM $ Range.analyseLambda bucket_fun) imgs - addOpRanges (Screma w (ScremaForm scans reds map_lam) arrs) = - Screma w (ScremaForm - (map onScan scans) - (map onRed reds) - (Range.runRangeM $ Range.analyseLambda map_lam)) - arrs - where onRed red = - red { redLambda = Range.runRangeM $ Range.analyseLambda $ redLambda red } - onScan red = - red { scanLambda = Range.runRangeM $ Range.analyseLambda $ scanLambda red } - -instance (Attributes lore, CanBeWise (Op lore)) => CanBeWise (SOAC lore) where - type OpWithWisdom (SOAC lore) = SOAC (Wise lore) - - removeOpWisdom = runIdentity . mapSOACM remove - where remove = SOACMapper return (return . removeLambdaWisdom) return - -instance Annotations lore => ST.IndexOp (SOAC lore) where - indexOp vtable k soac [i] = do - (lam,se,arr_params,arrs) <- lambdaAndSubExp soac - let arr_indexes = M.fromList $ catMaybes $ zipWith arrIndex arr_params arrs - arr_indexes' = foldl expandPrimExpTable arr_indexes $ bodyStms $ lambdaBody lam - case se of - Var v -> uncurry (flip ST.Indexed) <$> M.lookup v arr_indexes' - _ -> Nothing - where lambdaAndSubExp (Screma _ (ScremaForm scans reds map_lam) arrs) = - nthMapOut (scanResults scans + redResults reds) map_lam arrs - lambdaAndSubExp _ = - Nothing - - nthMapOut num_accs lam arrs = do - se <- maybeNth (num_accs+k) $ bodyResult $ lambdaBody lam - return (lam, se, drop num_accs $ lambdaParams lam, arrs) - - arrIndex p arr = do - ST.Indexed cs pe <- ST.index' arr [i] vtable - return (paramName p, (pe,cs)) - - expandPrimExpTable table stm - | [v] <- patternNames $ stmPattern stm, - Just (pe,cs) <- - runWriterT $ primExpFromExp (asPrimExp table) $ stmExp stm, - all (`ST.elem` vtable) (unCertificates $ stmCerts stm) = - M.insert v (pe, stmCerts stm <> cs) table - | otherwise = - table - - asPrimExp table v - | Just (e,cs) <- M.lookup v table = tell cs >> return e - | Just (Prim pt) <- ST.lookupType v vtable = - return $ LeafExp v pt - | otherwise = lift Nothing - indexOp _ _ _ _ = Nothing - -typeCheckSOAC :: TC.Checkable lore => SOAC (Aliases lore) -> TC.TypeM lore () -typeCheckSOAC (Stream size form lam arrexps) = do - let accexps = getStreamAccums form - TC.require [Prim int32] size - accargs <- mapM TC.checkArg accexps - arrargs <- mapM lookupType arrexps - _ <- TC.checkSOACArrayArgs size arrexps - let chunk = head $ lambdaParams lam - let asArg t = (t, mempty) - inttp = Prim int32 - lamarrs'= map (`setOuterSize` Var (paramName chunk)) arrargs - let acc_len= length accexps - let lamrtp = take acc_len $ lambdaReturnType lam - unless (map TC.argType accargs == lamrtp) $ - TC.bad $ TC.TypeError "Stream with inconsistent accumulator type in lambda." - -- check reduce's lambda, if any - _ <- case form of - Parallel _ _ lam0 _ -> do - let acct = map TC.argType accargs - outerRetType = lambdaReturnType lam0 - TC.checkLambda lam0 $ map TC.noArgAliases $ accargs ++ accargs - unless (acct == outerRetType) $ - TC.bad $ TC.TypeError $ - "Initial value is of type " ++ prettyTuple acct ++ - ", but stream's reduce lambda returns type " ++ prettyTuple outerRetType ++ "." - _ -> return () - -- just get the dflow of lambda on the fakearg, which does not alias - -- arr, so we can later check that aliases of arr are not used inside lam. - let fake_lamarrs' = map asArg lamarrs' - TC.checkLambda lam $ asArg inttp : accargs ++ fake_lamarrs' - -typeCheckSOAC (Scatter w lam ivs as) = do - -- Requirements: - -- - -- 0. @lambdaReturnType@ of @lam@ must be a list - -- [index types..., value types]. - -- - -- 1. The number of index types must be equal to the number of value types - -- and the number of writes to arrays in @as@. - -- - -- 2. Each index type must have the type i32. - -- - -- 3. Each array in @as@ and the value types must have the same type - -- - -- 4. Each array in @as@ is consumed. This is not really a check, but more - -- of a requirement, so that e.g. the source is not hoisted out of a - -- loop, which will mean it cannot be consumed. - -- - -- 5. Each of ivs must be an array matching a corresponding lambda - -- parameters. - -- - -- Code: - - -- First check the input size. - TC.require [Prim int32] w - - -- 0. - let (_as_ws, as_ns, _as_vs) = unzip3 as - rts = lambdaReturnType lam - rtsLen = length rts `div` 2 - rtsI = take rtsLen rts - rtsV = drop rtsLen rts - - -- 1. - unless (rtsLen == sum as_ns) - $ TC.bad $ TC.TypeError "Scatter: Uneven number of index types, value types, and arrays outputs." - - -- 2. - forM_ rtsI $ \rtI -> unless (Prim int32 == rtI) $ - TC.bad $ TC.TypeError "Scatter: Index return type must be i32." - - forM_ (zip (chunks as_ns rtsV) as) $ \(rtVs, (aw, _, a)) -> do - -- All lengths must have type i32. - TC.require [Prim int32] aw - - -- 3. - forM_ rtVs $ \rtV -> TC.requireI [rtV `arrayOfRow` aw] a - - -- 4. - TC.consume =<< TC.lookupAliases a - - -- 5. - arrargs <- TC.checkSOACArrayArgs w ivs - TC.checkLambda lam arrargs - -typeCheckSOAC (Hist len ops bucket_fun imgs) = do - TC.require [Prim int32] len - - -- Check the operators. - forM_ ops $ \(HistOp dest_w rf dests nes op) -> do - nes' <- mapM TC.checkArg nes - TC.require [Prim int32] dest_w - TC.require [Prim int32] rf - - -- Operator type must match the type of neutral elements. - TC.checkLambda op $ map TC.noArgAliases $ nes' ++ nes' - let nes_t = map TC.argType nes' - unless (nes_t == lambdaReturnType op) $ - TC.bad $ TC.TypeError $ "Operator has return type " ++ - prettyTuple (lambdaReturnType op) ++ " but neutral element has type " ++ - prettyTuple nes_t - - -- Arrays must have proper type. - forM_ (zip nes_t dests) $ \(t, dest) -> do - TC.requireI [t `arrayOfRow` dest_w] dest - TC.consume =<< TC.lookupAliases dest - - -- Types of input arrays must equal parameter types for bucket function. - img' <- TC.checkSOACArrayArgs len imgs - TC.checkLambda bucket_fun img' - - -- Return type of bucket function must be an index for each - -- operation followed by the values to write. - nes_ts <- concat <$> mapM (mapM subExpType . histNeutral) ops - let bucket_ret_t = replicate (length ops) (Prim int32) ++ nes_ts - unless (bucket_ret_t == lambdaReturnType bucket_fun) $ - TC.bad $ TC.TypeError $ "Bucket function has return type " ++ - prettyTuple (lambdaReturnType bucket_fun) ++ " but should have type " ++ - prettyTuple bucket_ret_t - -typeCheckSOAC (Screma w (ScremaForm scans reds map_lam) arrs) = do - TC.require [Prim int32] w - arrs' <- TC.checkSOACArrayArgs w arrs - TC.checkLambda map_lam $ map TC.noArgAliases arrs' - - scan_nes' <- fmap concat $ forM scans $ \(Scan scan_lam scan_nes) -> do - scan_nes' <- mapM TC.checkArg scan_nes - let scan_t = map TC.argType scan_nes' - TC.checkLambda scan_lam $ map TC.noArgAliases $ scan_nes' ++ scan_nes' - unless (scan_t == lambdaReturnType scan_lam) $ - TC.bad $ TC.TypeError $ "Scan function returns type " ++ - prettyTuple (lambdaReturnType scan_lam) ++ " but neutral element has type " ++ - prettyTuple scan_t - return scan_nes' - - red_nes' <- fmap concat $ forM reds $ \(Reduce _ red_lam red_nes) -> do - red_nes' <- mapM TC.checkArg red_nes - let red_t = map TC.argType red_nes' - TC.checkLambda red_lam $ map TC.noArgAliases $ red_nes' ++ red_nes' - unless (red_t == lambdaReturnType red_lam) $ - TC.bad $ TC.TypeError $ "Reduce function returns type " ++ - prettyTuple (lambdaReturnType red_lam) ++ " but neutral element has type " ++ - prettyTuple red_t - return red_nes' - - let map_lam_ts = lambdaReturnType map_lam - - unless (take (length scan_nes' + length red_nes') map_lam_ts == - map TC.argType (scan_nes'++ red_nes')) $ - TC.bad $ TC.TypeError $ "Map function return type " ++ prettyTuple map_lam_ts ++ - " wrong for given scan and reduction functions." - --- | Get Stream's accumulators as a sub-expression list -getStreamAccums :: StreamForm lore -> [SubExp] -getStreamAccums (Parallel _ _ _ accs) = accs -getStreamAccums (Sequential accs) = accs - -getStreamOrder :: StreamForm lore -> StreamOrd -getStreamOrder (Parallel o _ _ _) = o -getStreamOrder (Sequential _) = InOrder - -instance OpMetrics (Op lore) => OpMetrics (SOAC lore) where - opMetrics (Stream _ _ lam _) = - inside "Stream" $ lambdaMetrics lam - opMetrics (Scatter _len lam _ivs _as) = - inside "Scatter" $ lambdaMetrics lam - opMetrics (Hist _len ops bucket_fun _imgs) = - inside "Hist" $ mapM_ (lambdaMetrics . histOp) ops >> lambdaMetrics bucket_fun - opMetrics (Screma _ (ScremaForm scans reds map_lam) _) = - inside "Screma" $ do mapM_ (lambdaMetrics . scanLambda) scans - mapM_ (lambdaMetrics . redLambda) reds - lambdaMetrics map_lam - -instance PrettyLore lore => PP.Pretty (SOAC lore) where - ppr (Stream size form lam arrs) = - case form of - Parallel o comm lam0 acc -> - let ord_str = if o == Disorder then "Per" else "" - comm_str = case comm of Commutative -> "Comm" - Noncommutative -> "" - in text ("streamPar"++ord_str++comm_str) <> - parens (ppr size <> comma ppr lam0 comma ppr lam - commasep ( PP.braces (commasep $ map ppr acc) : map ppr arrs )) - Sequential acc -> - text "streamSeq" <> - parens (ppr size <> comma ppr lam <> comma - commasep ( PP.braces (commasep $ map ppr acc) : map ppr arrs )) - ppr (Scatter len lam ivs as) = - ppSOAC "scatter" len [lam] (Just (map Var ivs)) (map (\(_,n,a) -> (n,a)) as) - ppr (Hist len ops bucket_fun imgs) = - ppHist len ops bucket_fun imgs - ppr (Screma w (ScremaForm scans reds map_lam) arrs) - | null scans, null reds = - text "map" <> - parens (ppr w <> comma - ppr map_lam <> comma - commasep (map ppr arrs)) - - | null scans = - text "redomap" <> - parens (ppr w <> comma - PP.braces (mconcat $ intersperse (comma <> PP.line) $ map ppr reds) <> comma - ppr map_lam <> comma - commasep (map ppr arrs)) - - | null reds = - text "scanomap" <> - parens (ppr w <> comma - PP.braces (mconcat $ intersperse (comma <> PP.line) $ map ppr scans) <> comma - ppr map_lam <> comma - commasep (map ppr arrs)) - - ppr (Screma w form arrs) = ppScrema w form arrs - -ppScrema :: (PrettyLore lore, Pretty inp) => - SubExp -> ScremaForm lore -> [inp] -> Doc -ppScrema w (ScremaForm scans reds map_lam) arrs = - text "screma" <> - parens (ppr w <> comma - PP.braces (mconcat $ intersperse (comma <> PP.line) $ map ppr scans) <> comma - PP.braces (mconcat $ intersperse (comma <> PP.line) $ map ppr reds) <> comma - ppr map_lam <> comma - commasep (map ppr arrs)) - -instance PrettyLore lore => Pretty (Scan lore) where - ppr (Scan scan_lam scan_nes) = - ppr scan_lam <> comma PP.braces (commasep $ map ppr scan_nes) - -ppComm :: Commutativity -> Doc -ppComm Noncommutative = mempty -ppComm Commutative = text "commutative " - -instance PrettyLore lore => Pretty (Reduce lore) where - ppr (Reduce comm red_lam red_nes) = - ppComm comm <> ppr red_lam <> comma - PP.braces (commasep $ map ppr red_nes) - -ppHist :: (PrettyLore lore, Pretty inp) => - SubExp -> [HistOp lore] -> Lambda lore -> [inp] -> Doc -ppHist len ops bucket_fun imgs = - text "hist" <> - parens (ppr len <> comma - PP.braces (mconcat $ intersperse (comma <> PP.line) $ map ppOp ops) <> comma - ppr bucket_fun <> comma - commasep (map ppr imgs)) - where ppOp (HistOp w rf dests nes op) = - ppr w <> comma <+> ppr rf <> comma <+> PP.braces (commasep $ map ppr dests) <> comma - PP.braces (commasep $ map ppr nes) <> comma ppr op - -ppSOAC :: (Pretty fn, Pretty v) => - String -> SubExp -> [fn] -> Maybe [SubExp] -> [v] -> Doc -ppSOAC name size funs es as = - text name <> parens (ppr size <> comma - ppList funs - commasep (es' ++ map ppr as)) - where es' = maybe [] ((:[]) . ppTuple') es - -ppList :: Pretty a => [a] -> Doc -ppList as = case map ppr as of - [] -> mempty - a':as' -> foldl () (a' <> comma) $ map (<> comma) as' diff --git a/src/Futhark/Representation/SOACS/Simplify.hs b/src/Futhark/Representation/SOACS/Simplify.hs deleted file mode 100644 --- a/src/Futhark/Representation/SOACS/Simplify.hs +++ /dev/null @@ -1,793 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -module Futhark.Representation.SOACS.Simplify - ( simplifySOACS - , simplifyLambda - , simplifyFun - , simplifyStms - , simplifyConsts - - , simpleSOACS - , simplifySOAC - - , soacRules - - , SOACS - ) -where - -import Control.Monad -import Control.Monad.Identity -import Control.Monad.State -import Control.Monad.Writer -import Data.Foldable -import Data.Either -import Data.List (partition, transpose, unzip6, zip6) -import Data.Maybe -import qualified Data.Map.Strict as M -import qualified Data.Set as S - -import Futhark.Representation.SOACS -import qualified Futhark.Representation.AST as AST -import Futhark.Representation.AST.Attributes.Aliases -import qualified Futhark.Optimise.Simplify.Engine as Engine -import qualified Futhark.Optimise.Simplify as Simplify -import Futhark.Optimise.Simplify.Rules -import Futhark.MonadFreshNames -import Futhark.Optimise.Simplify.Rule -import Futhark.Optimise.Simplify.ClosedForm -import Futhark.Optimise.Simplify.Lore -import Futhark.Tools -import Futhark.Pass -import qualified Futhark.Analysis.SymbolTable as ST -import qualified Futhark.Analysis.UsageTable as UT -import Futhark.Analysis.DataDependencies -import Futhark.Transform.Rename -import Futhark.Util - -simpleSOACS :: Simplify.SimpleOps SOACS -simpleSOACS = Simplify.bindableSimpleOps simplifySOAC - -simplifySOACS :: Prog SOACS -> PassM (Prog SOACS) -simplifySOACS = Simplify.simplifyProg simpleSOACS soacRules blockers - where blockers = Engine.noExtraHoistBlockers { Engine.getArraySizes = getShapeNames } - --- | Getting the roots of what to hoist, for now only variable --- names that represent shapes/sizes. -getShapeNames :: (LetAttr lore ~ (VarWisdom, Type)) => - AST.Stm lore -> Names -getShapeNames bnd = - let tps1 = map patElemType $ patternElements $ stmPattern bnd - tps2 = map (snd . patElemAttr) $ patternElements $ stmPattern bnd - in namesFromList $ subExpVars $ concatMap arrayDims (tps1 ++ tps2) - -simplifyFun :: MonadFreshNames m => - ST.SymbolTable (Wise SOACS) -> FunDef SOACS -> m (FunDef SOACS) -simplifyFun = - Simplify.simplifyFun simpleSOACS soacRules Engine.noExtraHoistBlockers - -simplifyLambda :: (HasScope SOACS m, MonadFreshNames m) => - Lambda -> [Maybe VName] -> m Lambda -simplifyLambda = - Simplify.simplifyLambda simpleSOACS soacRules Engine.noExtraHoistBlockers - -simplifyStms :: (HasScope SOACS m, MonadFreshNames m) => - Stms SOACS -> m (ST.SymbolTable (Wise SOACS), Stms SOACS) -simplifyStms stms = do - scope <- askScope - Simplify.simplifyStms simpleSOACS soacRules Engine.noExtraHoistBlockers - scope stms - -simplifyConsts :: MonadFreshNames m => - Stms SOACS -> m (ST.SymbolTable (Wise SOACS), Stms SOACS) -simplifyConsts = - Simplify.simplifyStms simpleSOACS soacRules Engine.noExtraHoistBlockers mempty - -simplifySOAC :: Simplify.SimplifiableLore lore => - Simplify.SimplifyOp lore (SOAC lore) -simplifySOAC (Stream outerdim form lam arr) = do - outerdim' <- Engine.simplify outerdim - (form', form_hoisted) <- simplifyStreamForm form - arr' <- mapM Engine.simplify arr - (lam', lam_hoisted) <- Engine.simplifyLambda lam (map Just arr) - return (Stream outerdim' form' lam' arr', form_hoisted <> lam_hoisted) - where simplifyStreamForm (Parallel o comm lam0 acc) = do - acc' <- mapM Engine.simplify acc - (lam0', hoisted) <- Engine.simplifyLambda lam0 $ - replicate (length $ lambdaParams lam0) Nothing - return (Parallel o comm lam0' acc', hoisted) - simplifyStreamForm (Sequential acc) = do - acc' <- mapM Engine.simplify acc - return (Sequential acc', mempty) - -simplifySOAC (Scatter len lam ivs as) = do - len' <- Engine.simplify len - (lam', hoisted) <- Engine.simplifyLambda lam $ map Just ivs - ivs' <- mapM Engine.simplify ivs - as' <- mapM Engine.simplify as - return (Scatter len' lam' ivs' as', hoisted) - -simplifySOAC (Hist w ops bfun imgs) = do - w' <- Engine.simplify w - (ops', hoisted) <- fmap unzip $ forM ops $ \(HistOp dests_w rf dests nes op) -> do - dests_w' <- Engine.simplify dests_w - rf' <- Engine.simplify rf - dests' <- Engine.simplify dests - nes' <- mapM Engine.simplify nes - (op', hoisted) <- Engine.simplifyLambda op $ replicate (length $ lambdaParams op) Nothing - return (HistOp dests_w' rf' dests' nes' op', hoisted) - imgs' <- mapM Engine.simplify imgs - (bfun', bfun_hoisted) <- Engine.simplifyLambda bfun $ map Just imgs - return (Hist w' ops' bfun' imgs', mconcat hoisted <> bfun_hoisted) - -simplifySOAC (Screma w (ScremaForm scans reds map_lam) arrs) = do - (scans', scans_hoisted) <- fmap unzip $ forM scans $ \(Scan lam nes) -> do - (lam', hoisted) <- Engine.simplifyLambda lam $ replicate (length nes) Nothing - nes' <- Engine.simplify nes - return (Scan lam' nes', hoisted) - - (reds', reds_hoisted) <- fmap unzip $ forM reds $ \(Reduce comm lam nes) -> do - (lam', hoisted) <- Engine.simplifyLambda lam $ replicate (length nes) Nothing - nes' <- Engine.simplify nes - return (Reduce comm lam' nes', hoisted) - - (map_lam', map_lam_hoisted) <- Engine.simplifyLambda map_lam $ map Just arrs - - (,) <$> (Screma <$> Engine.simplify w <*> - (ScremaForm <$> pure scans' <*> pure reds' <*> pure map_lam') <*> - Engine.simplify arrs) <*> - pure (mconcat scans_hoisted <> mconcat reds_hoisted <> map_lam_hoisted) - -instance BinderOps (Wise SOACS) where - mkExpAttrB = bindableMkExpAttrB - mkBodyB = bindableMkBodyB - mkLetNamesB = bindableMkLetNamesB - -fixLambdaParams :: (MonadBinder m, Bindable (Lore m), BinderOps (Lore m)) => - AST.Lambda (Lore m) -> [Maybe SubExp] -> m (AST.Lambda (Lore m)) -fixLambdaParams lam fixes = do - body <- runBodyBinder $ localScope (scopeOfLParams $ lambdaParams lam) $ do - zipWithM_ maybeFix (lambdaParams lam) fixes' - return $ lambdaBody lam - return lam { lambdaBody = body - , lambdaParams = map fst $ filter (isNothing . snd) $ - zip (lambdaParams lam) fixes' } - where fixes' = fixes ++ repeat Nothing - maybeFix p (Just x) = letBindNames_ [paramName p] $ BasicOp $ SubExp x - maybeFix _ Nothing = return () - -removeLambdaResults :: [Bool] -> AST.Lambda lore -> AST.Lambda lore -removeLambdaResults keep lam = lam { lambdaBody = lam_body' - , lambdaReturnType = ret } - where keep' :: [a] -> [a] - keep' = map snd . filter fst . zip (keep ++ repeat True) - lam_body = lambdaBody lam - lam_body' = lam_body { bodyResult = keep' $ bodyResult lam_body } - ret = keep' $ lambdaReturnType lam - -soacRules :: RuleBook (Wise SOACS) -soacRules = standardRules <> ruleBook topDownRules bottomUpRules - -topDownRules :: [TopDownRule (Wise SOACS)] -topDownRules = [RuleOp hoistCertificates, - RuleOp removeReplicateMapping, - RuleOp removeReplicateWrite, - RuleOp removeUnusedSOACInput, - RuleOp simplifyClosedFormReduce, - RuleOp simplifyKnownIterationSOAC, - RuleOp fuseConcatScatter, - RuleOp simplifyMapIota, - RuleOp moveTransformToInput - ] - -bottomUpRules :: [BottomUpRule (Wise SOACS)] -bottomUpRules = [RuleOp removeDeadMapping, - RuleOp removeDeadReduction, - RuleOp removeDeadWrite, - RuleBasicOp removeUnnecessaryCopy, - RuleOp liftIdentityMapping, - RuleOp liftIdentityStreaming, - RuleOp removeDuplicateMapOutput, - RuleOp mapOpToOp - ] - --- Any certificates attached to a trivial Stm in the body might as --- well be applied to the SOAC itself. -hoistCertificates :: TopDownRuleOp (Wise SOACS) -hoistCertificates vtable pat aux soac - | (soac', hoisted) <- runState (mapSOACM mapper soac) mempty, - hoisted /= mempty = - Simplify $ certifying (hoisted <> stmAuxCerts aux) $ letBind_ pat $ Op soac' - where mapper = identitySOACMapper { mapOnSOACLambda = onLambda } - onLambda lam = do - stms' <- mapM onStm $ bodyStms $ lambdaBody lam - return lam { lambdaBody = - mkBody stms' $ bodyResult $ lambdaBody lam } - onStm (Let se_pat se_aux (BasicOp (SubExp se))) = do - let (invariant, variant) = - partition (`ST.elem` vtable) $ - unCertificates $ stmAuxCerts se_aux - se_aux' = se_aux { stmAuxCerts = Certificates variant } - modify (Certificates invariant<>) - return $ Let se_pat se_aux' $ BasicOp $ SubExp se - onStm stm = return stm -hoistCertificates _ _ _ _ = - Skip - -liftIdentityMapping :: BottomUpRuleOp (Wise SOACS) -liftIdentityMapping (_, usages) pat _ (Screma w form arrs) - | Just fun <- isMapSOAC form = do - let inputMap = M.fromList $ zip (map paramName $ lambdaParams fun) arrs - free = freeIn $ lambdaBody fun - rettype = lambdaReturnType fun - ses = bodyResult $ lambdaBody fun - - freeOrConst (Var v) = v `nameIn` free - freeOrConst Constant{} = True - - checkInvariance (outId, Var v, _) (invariant, mapresult, rettype') - | Just inp <- M.lookup v inputMap = - let e | patElemName outId `UT.isConsumed` usages - || inp `UT.isConsumed` usages = - Copy inp - | otherwise = - SubExp $ Var inp - in ((Pattern [] [outId], BasicOp e) : invariant, - mapresult, - rettype') - checkInvariance (outId, e, t) (invariant, mapresult, rettype') - | freeOrConst e = ((Pattern [] [outId], BasicOp $ Replicate (Shape [w]) e) : invariant, - mapresult, - rettype') - | otherwise = (invariant, - (outId, e) : mapresult, - t : rettype') - - case foldr checkInvariance ([], [], []) $ - zip3 (patternElements pat) ses rettype of - ([], _, _) -> Skip - (invariant, mapresult, rettype') -> Simplify $ do - let (pat', ses') = unzip mapresult - fun' = fun { lambdaBody = (lambdaBody fun) { bodyResult = ses' } - , lambdaReturnType = rettype' - } - mapM_ (uncurry letBind) invariant - letBindNames_ (map patElemName pat') $ Op $ Screma w (mapSOAC fun') arrs -liftIdentityMapping _ _ _ _ = Skip - -liftIdentityStreaming :: BottomUpRuleOp (Wise SOACS) -liftIdentityStreaming _ (Pattern [] pes) _ (Stream w form lam arrs) - | (variant_map, invariant_map) <- - partitionEithers $ map isInvariantRes $ zip3 map_ts map_pes map_res, - not $ null invariant_map = Simplify $ do - - forM_ invariant_map $ \(pe, arr) -> - letBind_ (Pattern [] [pe]) $ BasicOp $ Copy arr - - let (variant_map_ts, variant_map_pes, variant_map_res) = unzip3 variant_map - lam' = lam { lambdaBody = (lambdaBody lam) { bodyResult = fold_res ++ variant_map_res } - , lambdaReturnType = fold_ts ++ variant_map_ts } - - letBind_ (Pattern [] $ fold_pes ++ variant_map_pes) $ - Op $ Stream w form lam' arrs - where num_folds = length $ getStreamAccums form - (fold_pes, map_pes) = splitAt num_folds pes - (fold_ts, map_ts) = splitAt num_folds $ lambdaReturnType lam - lam_res = bodyResult $ lambdaBody lam - (fold_res, map_res) = splitAt num_folds lam_res - params_to_arrs = zip (map paramName $ drop (1 + num_folds) $ lambdaParams lam) arrs - - isInvariantRes (_, pe, Var v) - | Just arr <- lookup v params_to_arrs = - Right (pe, arr) - isInvariantRes x = - Left x -liftIdentityStreaming _ _ _ _ = Skip - --- | Remove all arguments to the map that are simply replicates. --- These can be turned into free variables instead. -removeReplicateMapping :: TopDownRuleOp (Wise SOACS) -removeReplicateMapping vtable pat _ (Screma w form arrs) - | Just fun <- isMapSOAC form, - Just (bnds, fun', arrs') <- removeReplicateInput vtable fun arrs = Simplify $ do - forM_ bnds $ \(vs,cs,e) -> certifying cs $ letBindNames vs e - letBind_ pat $ Op $ Screma w (mapSOAC fun') arrs' -removeReplicateMapping _ _ _ _ = Skip - --- | Like 'removeReplicateMapping', but for 'Scatter'. -removeReplicateWrite :: TopDownRuleOp (Wise SOACS) -removeReplicateWrite vtable pat _ (Scatter len lam ivs as) - | Just (bnds, lam', ivs') <- removeReplicateInput vtable lam ivs = Simplify $ do - forM_ bnds $ \(vs,cs,e) -> certifying cs $ letBindNames vs e - letBind_ pat $ Op $ Scatter len lam' ivs' as -removeReplicateWrite _ _ _ _ = Skip - -removeReplicateInput :: Aliased lore => - ST.SymbolTable lore - -> AST.Lambda lore -> [VName] - -> Maybe ([([VName], Certificates, AST.Exp lore)], - AST.Lambda lore, [VName]) -removeReplicateInput vtable fun arrs - | not $ null parameterBnds = do - let (arr_params', arrs') = unzip params_and_arrs - fun' = fun { lambdaParams = acc_params <> arr_params' } - return (parameterBnds, fun', arrs') - | otherwise = Nothing - - where params = lambdaParams fun - (acc_params, arr_params) = - splitAt (length params - length arrs) params - (params_and_arrs, parameterBnds) = - partitionEithers $ zipWith isReplicateAndNotConsumed arr_params arrs - - isReplicateAndNotConsumed p v - | Just (BasicOp (Replicate (Shape (_:ds)) e), v_cs) <- - ST.lookupExp v vtable, - not $ paramName p `nameIn` consumedByLambda fun = - Right ([paramName p], - v_cs, - case ds of - [] -> BasicOp $ SubExp e - _ -> BasicOp $ Replicate (Shape ds) e) - | otherwise = - Left (p, v) - --- | Remove inputs that are not used inside the SOAC. -removeUnusedSOACInput :: TopDownRuleOp (Wise SOACS) -removeUnusedSOACInput _ pat _ (Screma w (ScremaForm scan reduce map_lam) arrs) - | (used,unused) <- partition usedInput params_and_arrs, - not (null unused) = Simplify $ do - let (used_params, used_arrs) = unzip used - map_lam' = map_lam { lambdaParams = used_params } - letBind_ pat $ Op $ Screma w (ScremaForm scan reduce map_lam') used_arrs - where params_and_arrs = zip (lambdaParams map_lam) arrs - used_in_body = freeIn $ lambdaBody map_lam - usedInput (param, _) = paramName param `nameIn` used_in_body -removeUnusedSOACInput _ _ _ _ = Skip - -removeDeadMapping :: BottomUpRuleOp (Wise SOACS) -removeDeadMapping (_, used) pat _ (Screma w form arrs) - | Just fun <- isMapSOAC form = - let ses = bodyResult $ lambdaBody fun - isUsed (bindee, _, _) = (`UT.used` used) $ patElemName bindee - (pat',ses', ts') = unzip3 $ filter isUsed $ - zip3 (patternElements pat) ses $ lambdaReturnType fun - fun' = fun { lambdaBody = (lambdaBody fun) { bodyResult = ses' } - , lambdaReturnType = ts' - } - in if pat /= Pattern [] pat' - then Simplify $ letBind_ (Pattern [] pat') $ Op $ Screma w (mapSOAC fun') arrs - else Skip -removeDeadMapping _ _ _ _ = Skip - -removeDuplicateMapOutput :: BottomUpRuleOp (Wise SOACS) -removeDuplicateMapOutput (_, used) pat _ (Screma w form arrs) - | Just fun <- isMapSOAC form = - let ses = bodyResult $ lambdaBody fun - ts = lambdaReturnType fun - pes = patternValueElements pat - ses_ts_pes = zip3 ses ts pes - (ses_ts_pes', copies) = - foldl checkForDuplicates (mempty,mempty) ses_ts_pes - in if null copies then Skip - else Simplify $ do - let (ses', ts', pes') = unzip3 ses_ts_pes' - pat' = Pattern [] pes' - fun' = fun { lambdaBody = (lambdaBody fun) { bodyResult = ses' } - , lambdaReturnType = ts' } - letBind_ pat' $ Op $ Screma w (mapSOAC fun') arrs - forM_ copies $ \(from,to) -> - if UT.isConsumed (patElemName to) used then - letBind_ (Pattern [] [to]) $ BasicOp $ Copy $ patElemName from - else - letBind_ (Pattern [] [to]) $ BasicOp $ SubExp $ Var $ patElemName from - where checkForDuplicates (ses_ts_pes',copies) (se,t,pe) - | Just (_,_,pe') <- find (\(x,_,_) -> x == se) ses_ts_pes' = - -- This subexp has been returned before, producing the - -- array pe'. - (ses_ts_pes', (pe', pe) : copies) - | otherwise = (ses_ts_pes' ++ [(se,t,pe)], copies) -removeDuplicateMapOutput _ _ _ _ = Skip - --- Mapping some operations becomes an extension of that operation. -mapOpToOp :: BottomUpRuleOp (Wise SOACS) - -mapOpToOp (_, used) pat aux1 e - | Just (map_pe, cs, w, BasicOp (Reshape newshape reshape_arr), [p], [arr]) <- - isMapWithOp pat e, - paramName p == reshape_arr, - not $ UT.isConsumed (patElemName map_pe) used = Simplify $ do - let redim | isJust $ shapeCoercion newshape = DimCoercion w - | otherwise = DimNew w - certifying (stmAuxCerts aux1 <> cs) $ letBind_ pat $ - BasicOp $ Reshape (redim : newshape) arr - - | Just (_, cs, _, - BasicOp (Concat d arr arrs dw), ps, outer_arr : outer_arrs) <- - isMapWithOp pat e, - (arr:arrs) == map paramName ps = - Simplify $ certifying (stmAuxCerts aux1 <> cs) $ letBind_ pat $ - BasicOp $ Concat (d+1) outer_arr outer_arrs dw - - | Just (map_pe, cs, _, - BasicOp (Rearrange perm rearrange_arr), [p], [arr]) <- - isMapWithOp pat e, - paramName p == rearrange_arr, - not $ UT.isConsumed (patElemName map_pe) used = - Simplify $ certifying (stmAuxCerts aux1 <> cs) $ letBind_ pat $ - BasicOp $ Rearrange (0 : map (1+) perm) arr - - | Just (map_pe, cs, _, BasicOp (Rotate rots rotate_arr), [p], [arr]) <- - isMapWithOp pat e, - paramName p == rotate_arr, - not $ UT.isConsumed (patElemName map_pe) used = - Simplify $ certifying (stmAuxCerts aux1 <> cs) $ letBind_ pat $ - BasicOp $ Rotate (intConst Int32 0 : rots) arr - -mapOpToOp _ _ _ _ = Skip - -isMapWithOp :: PatternT attr - -> SOAC (Wise SOACS) - -> Maybe (PatElemT attr, Certificates, SubExp, - AST.Exp (Wise SOACS), [Param Type], [VName]) -isMapWithOp pat e - | Pattern [] [map_pe] <- pat, - Screma w form arrs <- e, - Just map_lam <- isMapSOAC form, - [Let (Pattern [] [pe]) aux2 e'] <- - stmsToList $ bodyStms $ lambdaBody map_lam, - [Var r] <- bodyResult $ lambdaBody map_lam, - r == patElemName pe = - Just (map_pe, stmAuxCerts aux2, w, e', lambdaParams map_lam, arrs) - | otherwise = Nothing - --- | Some of the results of a reduction (or really: Redomap) may be --- dead. We remove them here. The trick is that we need to look at --- the data dependencies to see that the "dead" result is not --- actually used for computing one of the live ones. -removeDeadReduction :: BottomUpRuleOp (Wise SOACS) -removeDeadReduction (_, used) pat (StmAux cs _) (Screma w form arrs) - | Just ([Reduce comm redlam nes], maplam) <- isRedomapSOAC form, - not $ all (`UT.used` used) $ patternNames pat, -- Quick/cheap check - - let (red_pes, map_pes) = splitAt (length nes) $ patternElements pat, - let redlam_deps = dataDependencies $ lambdaBody redlam, - let redlam_res = bodyResult $ lambdaBody redlam, - let redlam_params = lambdaParams redlam, - let used_after = map snd $ filter ((`UT.used` used) . patElemName . fst) $ - zip red_pes redlam_params, - let necessary = findNecessaryForReturned (`elem` used_after) - (zip redlam_params $ redlam_res <> redlam_res) redlam_deps, - let alive_mask = map ((`nameIn` necessary) . paramName) redlam_params, - - not $ all (==True) alive_mask = Simplify $ do - - let fixDeadToNeutral lives ne = if lives then Nothing else Just ne - dead_fix = zipWith fixDeadToNeutral alive_mask nes - (used_red_pes, _, used_nes) = - unzip3 $ filter (\(_,x,_) -> paramName x `nameIn` necessary) $ - zip3 red_pes redlam_params nes - - let maplam' = removeLambdaResults (take (length nes) alive_mask) maplam - redlam' <- removeLambdaResults (take (length nes) alive_mask) <$> fixLambdaParams redlam (dead_fix++dead_fix) - - certifying cs $ letBind_ (Pattern [] $ used_red_pes ++ map_pes) $ - Op $ Screma w (redomapSOAC [Reduce comm redlam' used_nes] maplam') arrs - -removeDeadReduction _ _ _ _ = Skip - --- | If we are writing to an array that is never used, get rid of it. -removeDeadWrite :: BottomUpRuleOp (Wise SOACS) -removeDeadWrite (_, used) pat _ (Scatter w fun arrs dests) = - let (i_ses, v_ses) = splitAt (length dests) $ bodyResult $ lambdaBody fun - (i_ts, v_ts) = splitAt (length dests) $ lambdaReturnType fun - isUsed (bindee, _, _, _, _, _) = (`UT.used` used) $ patElemName bindee - (pat', i_ses', v_ses', i_ts', v_ts', dests') = - unzip6 $ filter isUsed $ - zip6 (patternElements pat) i_ses v_ses i_ts v_ts dests - fun' = fun { lambdaBody = (lambdaBody fun) { bodyResult = i_ses' ++ v_ses' } - , lambdaReturnType = i_ts' ++ v_ts' - } - in if pat /= Pattern [] pat' - then Simplify $ letBind_ (Pattern [] pat') $ Op $ Scatter w fun' arrs dests' - else Skip -removeDeadWrite _ _ _ _ = Skip - --- handles now concatenation of more than two arrays -fuseConcatScatter :: TopDownRuleOp (Wise SOACS) -fuseConcatScatter vtable pat _ (Scatter _ fun arrs dests) - | Just (ws@(w':_), xss, css) <- unzip3 <$> mapM isConcat arrs, - xivs <- transpose xss, - all (w'==) ws = Simplify $ do - let r = length xivs - fun2s <- mapM (\_ -> renameLambda fun) [1 .. r-1] - let fun_n = length $ lambdaReturnType fun - (fun_is, fun_vs) = unzip $ map (splitAt (fun_n `div` 2) . - bodyResult . lambdaBody ) (fun:fun2s) - (its, vts) = unzip $ replicate r $ - splitAt (fun_n `div` 2) $ lambdaReturnType fun - new_stmts = mconcat $ map (bodyStms . lambdaBody) (fun:fun2s) - let fun' = Lambda - { lambdaParams = mconcat $ map lambdaParams (fun:fun2s) - , lambdaBody = mkBody new_stmts $ - mix fun_is <> mix fun_vs - , lambdaReturnType = mix its <> mix vts - } - certifying (mconcat css) $ - letBind_ pat $ Op $ Scatter w' fun' (concat xivs) $ map (incWrites r) dests - where sizeOf :: VName -> Maybe SubExp - sizeOf x = arraySize 0 . ST.entryType <$> ST.lookup x vtable - mix = concat . transpose - incWrites r (w, n, a) = (w, n*r, a) -- ToDO: is it (n*r) or (n+r-1)?? - isConcat v = case ST.lookupExp v vtable of - Just (BasicOp (Concat 0 x ys _), cs) -> do - x_w <- sizeOf x - y_ws<- mapM sizeOf ys - guard $ all (x_w==) y_ws - return (x_w, x:ys, cs) - Just (BasicOp (Reshape reshape arr), cs) -> do - guard $ isJust $ shapeCoercion reshape - (a, b, cs') <- isConcat arr - return (a, b, cs <> cs') - _ -> Nothing - -fuseConcatScatter _ _ _ _ = Skip - -simplifyClosedFormReduce :: TopDownRuleOp (Wise SOACS) -simplifyClosedFormReduce _ pat _ (Screma (Constant w) form _) - | Just nes <- concatMap redNeutral . fst <$> isRedomapSOAC form, - zeroIsh w = - Simplify $ forM_ (zip (patternNames pat) nes) $ \(v, ne) -> - letBindNames_ [v] $ BasicOp $ SubExp ne -simplifyClosedFormReduce vtable pat _ (Screma _ form arrs) - | Just [Reduce _ red_fun nes] <- isReduceSOAC form = - Simplify $ foldClosedForm (`ST.lookupExp` vtable) pat red_fun nes arrs -simplifyClosedFormReduce _ _ _ _ = Skip - --- For now we just remove singleton SOACs. -simplifyKnownIterationSOAC :: TopDownRuleOp (Wise SOACS) -simplifyKnownIterationSOAC _ pat _ (Screma (Constant k) - (ScremaForm scans reds map_lam) - arrs) - | oneIsh k = Simplify $ do - zipWithM_ bindMapParam (lambdaParams map_lam) arrs - (to_scan, to_red, map_res) <- splitAt3 (length scan_nes) (length red_nes) <$> - bodyBind (lambdaBody map_lam) - scan_res <- eLambda scan_lam $ map eSubExp $ scan_nes ++ to_scan - red_res <- eLambda red_lam $ map eSubExp $ red_nes ++ to_red - - zipWithM_ bindArrayResult scan_pes scan_res - zipWithM_ bindResult red_pes red_res - zipWithM_ bindArrayResult map_pes map_res - - where (Reduce _ red_lam red_nes) = singleReduce reds - (Scan scan_lam scan_nes) = singleScan scans - (scan_pes, red_pes, map_pes) = splitAt3 (length scan_nes) (length red_nes) $ - patternElements pat - bindMapParam p a = do - a_t <- lookupType a - letBindNames_ [paramName p] $ - BasicOp $ Index a $ fullSlice a_t [DimFix $ constant (0::Int32)] - bindArrayResult pe se = - letBindNames_ [patElemName pe] $ - BasicOp $ ArrayLit [se] $ rowType $ patElemType pe - bindResult pe se = - letBindNames_ [patElemName pe] $ BasicOp $ SubExp se - -simplifyKnownIterationSOAC _ pat _ (Stream (Constant k) form fold_lam arrs) - | oneIsh k = Simplify $ do - let nes = getStreamAccums form - (chunk_param, acc_params, slice_params) = - partitionChunkedFoldParameters (length nes) (lambdaParams fold_lam) - - letBindNames_ [paramName chunk_param] $ - BasicOp $ SubExp $ intConst Int32 1 - - forM_ (zip acc_params nes) $ \(p, ne) -> - letBindNames_ [paramName p] $ BasicOp $ SubExp ne - - forM_ (zip slice_params arrs) $ \(p, arr) -> - letBindNames_ [paramName p] $ BasicOp $ SubExp $ Var arr - - res <- bodyBind $ lambdaBody fold_lam - - forM_ (zip (patternNames pat) res) $ \(v, se) -> - letBindNames_ [v] $ BasicOp $ SubExp se - -simplifyKnownIterationSOAC _ _ _ _ = Skip - -data ArrayOp = ArrayIndexing Certificates VName (Slice SubExp) - | ArrayRearrange Certificates VName [Int] - | ArrayRotate Certificates VName [SubExp] - | ArrayVar Certificates VName -- ^ Never constructed. - deriving (Eq, Ord, Show) - -arrayOpArr :: ArrayOp -> VName -arrayOpArr (ArrayIndexing _ arr _) = arr -arrayOpArr (ArrayRearrange _ arr _) = arr -arrayOpArr (ArrayRotate _ arr _) = arr -arrayOpArr (ArrayVar _ arr) = arr - -arrayOpCerts :: ArrayOp -> Certificates -arrayOpCerts (ArrayIndexing cs _ _) = cs -arrayOpCerts (ArrayRearrange cs _ _) = cs -arrayOpCerts (ArrayRotate cs _ _) = cs -arrayOpCerts (ArrayVar cs _) = cs - -isArrayOp :: Certificates -> AST.Exp (Wise SOACS) -> Maybe ArrayOp -isArrayOp cs (BasicOp (Index arr slice)) = - Just $ ArrayIndexing cs arr slice -isArrayOp cs (BasicOp (Rearrange perm arr)) = - Just $ ArrayRearrange cs arr perm -isArrayOp cs (BasicOp (Rotate rots arr)) = - Just $ ArrayRotate cs arr rots -isArrayOp _ _ = - Nothing - -fromArrayOp :: ArrayOp -> (Certificates, AST.Exp (Wise SOACS)) -fromArrayOp (ArrayIndexing cs arr slice) = (cs, BasicOp $ Index arr slice) -fromArrayOp (ArrayRearrange cs arr perm) = (cs, BasicOp $ Rearrange perm arr) -fromArrayOp (ArrayRotate cs arr rots) = (cs, BasicOp $ Rotate rots arr) -fromArrayOp (ArrayVar cs arr) = (cs, BasicOp $ SubExp $ Var arr) - -arrayOps :: AST.Body (Wise SOACS) -> S.Set (AST.Pattern (Wise SOACS), ArrayOp) -arrayOps = mconcat . map onStm . stmsToList . bodyStms - where onStm (Let pat aux e) = - case isArrayOp (stmAuxCerts aux) e of - Just op -> S.singleton (pat, op) - Nothing -> execState (walkExpM walker e) mempty - onOp = execWriter . mapSOACM identitySOACMapper { mapOnSOACLambda = onLambda } - onLambda lam = do tell $ arrayOps $ lambdaBody lam - return lam - walker = identityWalker { walkOnBody = modify . (<>) . arrayOps - , walkOnOp = modify . (<>) . onOp } - -replaceArrayOps :: M.Map ArrayOp ArrayOp - -> AST.Body (Wise SOACS) -> AST.Body (Wise SOACS) -replaceArrayOps substs (Body _ stms res) = - mkBody (fmap onStm stms) res - where onStm (Let pat aux e) = - let (cs', e') = onExp (stmAuxCerts aux) e - in certify cs' $ mkLet (patternContextIdents pat) (patternValueIdents pat) e' - onExp cs e - | Just op <- isArrayOp cs e, - Just op' <- M.lookup op substs = - fromArrayOp op' - onExp cs e = (cs, mapExp mapper e) - mapper = identityMapper { mapOnBody = const $ return . replaceArrayOps substs - , mapOnOp = return . onOp } - onOp = runIdentity . mapSOACM identitySOACMapper { mapOnSOACLambda = return . onLambda } - onLambda lam = lam { lambdaBody = replaceArrayOps substs $ lambdaBody lam } - --- Turn --- --- map (\i -> ... xs[i] ...) (iota n) --- --- into --- --- map (\i x -> ... x ...) (iota n) xs --- --- This is not because we want to encourage the map-iota pattern, but --- it may be present in generated code. This is an unfortunately --- expensive simplification rule, since it requires multiple passes --- over the entire lambda body. It only handles the very simplest --- case - if you find yourself planning to extend it to handle more --- complex situations (rotate or whatnot), consider turning it into a --- separate compiler pass instead. -simplifyMapIota :: TopDownRuleOp (Wise SOACS) -simplifyMapIota vtable pat _ (Screma w (ScremaForm scan reduce map_lam) arrs) - | Just (p, _) <- find isIota (zip (lambdaParams map_lam) arrs), - indexings <- filter (indexesWith (paramName p)) $ map snd $ S.toList $ - arrayOps $ lambdaBody map_lam, - not $ null indexings = Simplify $ do - -- For each indexing with iota, add the corresponding array to - -- the Screma, and construct a new lambda parameter. - (more_arrs, more_params, replacements) <- - unzip3 . catMaybes <$> mapM mapOverArr indexings - let substs = M.fromList $ zip indexings replacements - map_lam' = map_lam { lambdaParams = lambdaParams map_lam <> more_params - , lambdaBody = replaceArrayOps substs $ - lambdaBody map_lam - } - letBind_ pat $ Op $ Screma w (ScremaForm scan reduce map_lam') (arrs <> more_arrs) - where isIota (_, arr) = case ST.lookupBasicOp arr vtable of - Just (Iota _ (Constant o) (Constant s) _, _) -> - zeroIsh o && oneIsh s - _ -> False - - indexesWith v (ArrayIndexing cs arr (DimFix (Var i) : _)) - | arr `ST.elem` vtable, - all (`ST.elem` vtable) $ unCertificates cs = - i == v - indexesWith _ _ = False - - mapOverArr (ArrayIndexing cs arr slice) = do - arr_elem <- newVName $ baseString arr ++ "_elem" - arr_t <- lookupType arr - arr' <- if arraySize 0 arr_t == w - then return arr - else certifying cs $ letExp (baseString arr ++ "_prefix") $ - BasicOp $ Index arr $ - fullSlice arr_t [DimSlice (intConst Int32 0) w (intConst Int32 1)] - return $ Just (arr', - Param arr_elem (rowType arr_t), - ArrayIndexing cs arr_elem (drop 1 slice)) - - mapOverArr _ = return Nothing - -simplifyMapIota _ _ _ _ = Skip - --- If a Screma's map function contains a transformation --- (e.g. transpose) on a parameter, create a new parameter --- corresponding to that transformation performed on the rows of the --- full array. -moveTransformToInput :: TopDownRuleOp (Wise SOACS) -moveTransformToInput vtable pat _ (Screma w (ScremaForm scan reduce map_lam) arrs) - | ops <- map snd $ filter arrayIsMapParam $ S.toList $ arrayOps $ lambdaBody map_lam, - not $ null ops = Simplify $ do - (more_arrs, more_params, replacements) <- - unzip3 . catMaybes <$> mapM mapOverArr ops - - when (null more_arrs) cannotSimplify - - let substs = M.fromList $ zip ops replacements - map_lam' = map_lam { lambdaParams = lambdaParams map_lam <> more_params - , lambdaBody = replaceArrayOps substs $ - lambdaBody map_lam - } - - letBind_ pat $ Op $ Screma w (ScremaForm scan reduce map_lam') (arrs <> more_arrs) - - where map_param_names = map paramName (lambdaParams map_lam) - topLevelPattern = (`elem` fmap stmPattern (bodyStms (lambdaBody map_lam))) - onlyUsedOnce arr = - case filter ((arr `nameIn`) . freeIn) $ stmsToList $ bodyStms $ lambdaBody map_lam of - _ : _ : _ -> False - _ -> True - - -- It's not just about whether the array is a parameter; - -- everything else must be map-invariant. - arrayIsMapParam (pat', ArrayIndexing cs arr slice) = - arr `elem` map_param_names && - all (`ST.elem` vtable) (namesToList $ freeIn cs <> freeIn slice) && - not (null slice) && - (not (null $ sliceDims slice) || (topLevelPattern pat' && onlyUsedOnce arr)) - arrayIsMapParam (_, ArrayRearrange cs arr perm) = - arr `elem` map_param_names && - all (`ST.elem` vtable) (namesToList $ freeIn cs) && - not (null perm) - arrayIsMapParam (_, ArrayRotate cs arr rots) = - arr `elem` map_param_names && - all (`ST.elem` vtable) (namesToList $ freeIn cs <> freeIn rots) - arrayIsMapParam (_, ArrayVar{}) = - False - - mapOverArr op - | Just (_, arr) <- find ((==arrayOpArr op) . fst) (zip map_param_names arrs) = do - arr_t <- lookupType arr - let whole_dim = DimSlice (intConst Int32 0) (arraySize 0 arr_t) (intConst Int32 1) - arr_transformed <- certifying (arrayOpCerts op) $ - letExp (baseString arr ++ "_transformed") $ - case op of - ArrayIndexing _ _ slice -> - BasicOp $ Index arr $ whole_dim : slice - ArrayRearrange _ _ perm -> - BasicOp $ Rearrange (0 : map (+1) perm) arr - ArrayRotate _ _ rots -> - BasicOp $ Rotate (intConst Int32 0 : rots) arr - ArrayVar{} -> - BasicOp $ SubExp $ Var arr - arr_transformed_t <- lookupType arr_transformed - arr_transformed_row <- newVName $ baseString arr ++ "_transformed_row" - return $ Just (arr_transformed, - Param arr_transformed_row (rowType arr_transformed_t), - ArrayVar mempty arr_transformed_row) - - mapOverArr _ = return Nothing - -moveTransformToInput _ _ _ _ = - Skip diff --git a/src/Futhark/Representation/SegOp.hs b/src/Futhark/Representation/SegOp.hs deleted file mode 100644 --- a/src/Futhark/Representation/SegOp.hs +++ /dev/null @@ -1,1173 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} --- | Segmented operations. -module Futhark.Representation.SegOp - ( SegOp(..) - , SegVirt(..) - , segLevel - , segSpace - , typeCheckSegOp - , SegSpace(..) - , scopeOfSegSpace - , segSpaceDims - - -- * Details - , HistOp(..) - , histType - , SegBinOp(..) - , segBinOpResults - , segBinOpChunks - , KernelBody(..) - , aliasAnalyseKernelBody - , consumedInKernelBody - , ResultManifest(..) - , KernelResult(..) - , kernelResultSubExp - , SplitOrdering(..) - - -- ** Generic traversal - , SegOpMapper(..) - , identitySegOpMapper - , mapSegOpM - - -- * Simplification - , simplifyKernelBody - , simplifySegOp - , HasSegOp(..) - , segOpRules - - -- * Memory - , segOpReturns - ) -where - -import Control.Monad.State.Strict -import Control.Monad.Writer hiding (mapM_) -import Control.Monad.Identity hiding (mapM_) -import Data.Bifunctor (first) -import qualified Data.Map.Strict as M -import Data.Maybe -import Data.List - (intersperse, foldl', partition, isPrefixOf, groupBy) - -import Futhark.Representation.AST -import qualified Futhark.Analysis.Alias as Alias -import qualified Futhark.Analysis.SymbolTable as ST -import qualified Futhark.Analysis.UsageTable as UT -import Futhark.Analysis.PrimExp.Convert -import qualified Futhark.Util.Pretty as PP -import Futhark.Util.Pretty - ((), (<+>), ppr, commasep, Pretty, parens, text) -import Futhark.Transform.Substitute -import Futhark.Transform.Rename -import Futhark.Optimise.Simplify.Lore -import Futhark.Representation.Ranges - (Ranges, removeLambdaRanges, removeStmRanges, mkBodyRanges) -import Futhark.Representation.AST.Attributes.Ranges -import Futhark.Representation.AST.Attributes.Aliases -import Futhark.Representation.Aliases - (Aliases, removeLambdaAliases, removeStmAliases) -import Futhark.Representation.Mem -import qualified Futhark.TypeCheck as TC -import Futhark.Analysis.Metrics -import qualified Futhark.Analysis.Range as Range -import Futhark.Util (maybeNth, chunks) -import Futhark.Optimise.Simplify.Rule -import qualified Futhark.Optimise.Simplify.Engine as Engine -import Futhark.Tools - --- | How an array is split into chunks. -data SplitOrdering = SplitContiguous - | SplitStrided SubExp - deriving (Eq, Ord, Show) - -instance FreeIn SplitOrdering where - freeIn' SplitContiguous = mempty - freeIn' (SplitStrided stride) = freeIn' stride - -instance Substitute SplitOrdering where - substituteNames _ SplitContiguous = - SplitContiguous - substituteNames subst (SplitStrided stride) = - SplitStrided $ substituteNames subst stride - -instance Rename SplitOrdering where - rename SplitContiguous = - pure SplitContiguous - rename (SplitStrided stride) = - SplitStrided <$> rename stride - --- | An operator for 'SegHist'. -data HistOp lore = - HistOp { histWidth :: SubExp - , histRaceFactor :: SubExp - , histDest :: [VName] - , histNeutral :: [SubExp] - , histShape :: Shape - -- ^ In case this operator is semantically a vectorised - -- operator (corresponding to a perfect map nest in the - -- SOACS representation), these are the logical - -- "dimensions". This is used to generate more efficient - -- code. - , histOp :: Lambda lore - } - deriving (Eq, Ord, Show) - --- | The type of a histogram produced by a 'HistOp'. This can be --- different from the type of the 'HistDest's in case we are --- dealing with a segmented histogram. -histType :: HistOp lore -> [Type] -histType op = map ((`arrayOfRow` histWidth op) . - (`arrayOfShape` histShape op)) $ - lambdaReturnType $ histOp op - --- | An operator for 'SegScan' and 'SegRed'. -data SegBinOp lore = - SegBinOp { segBinOpComm :: Commutativity - , segBinOpLambda :: Lambda lore - , segBinOpNeutral :: [SubExp] - , segBinOpShape :: Shape - -- ^ In case this operator is semantically a vectorised - -- operator (corresponding to a perfect map nest in the - -- SOACS representation), these are the logical - -- "dimensions". This is used to generate more efficient - -- code. - } - deriving (Eq, Ord, Show) - --- | How many reduction results are produced by these 'SegBinOp's? -segBinOpResults :: [SegBinOp lore] -> Int -segBinOpResults = sum . map (length . segBinOpNeutral) - --- | Split some list into chunks equal to the number of values --- returned by each 'SegBinOp' -segBinOpChunks :: [SegBinOp lore] -> [a] -> [[a]] -segBinOpChunks = chunks . map (length . segBinOpNeutral) - --- | The body of a 'Kernel'. -data KernelBody lore = KernelBody { kernelBodyLore :: BodyAttr lore - , kernelBodyStms :: Stms lore - , kernelBodyResult :: [KernelResult] - } - -deriving instance Annotations lore => Ord (KernelBody lore) -deriving instance Annotations lore => Show (KernelBody lore) -deriving instance Annotations lore => Eq (KernelBody lore) - --- | Metadata about whether there is a subtle point to this --- 'KernelResult'. This is used to protect things like tiling, which --- might otherwise be removed by the simplifier because they're --- semantically redundant. This has no semantic effect and can be --- ignored at code generation. -data ResultManifest - = ResultNoSimplify - -- ^ Don't simplify this one! - | ResultMaySimplify - -- ^ Go nuts. - | ResultPrivate - -- ^ The results produced are only used within the - -- same physical thread later on, and can thus be - -- kept in registers. - deriving (Eq, Show, Ord) - --- | A 'KernelBody' does not return an ordinary 'Result'. Instead, it --- returns a list of these. -data KernelResult = Returns ResultManifest SubExp - -- ^ Each "worker" in the kernel returns this. - -- Whether this is a result-per-thread or a - -- result-per-group depends on the 'SegLevel'. - | WriteReturns - [SubExp] -- Size of array. Must match number of dims. - VName -- Which array - [([SubExp], SubExp)] - -- Arbitrary number of index/value pairs. - | ConcatReturns - SplitOrdering -- Permuted? - SubExp -- The final size. - SubExp -- Per-thread/group (max) chunk size. - VName -- Chunk by this worker. - | TileReturns - [(SubExp, SubExp)] -- Total/tile for each dimension - VName -- Tile written by this worker. - -- The TileReturns must not expect more than one - -- result to be written per physical thread. - deriving (Eq, Show, Ord) - --- | Get the root 'SubExp' corresponding values for a 'KernelResult'. -kernelResultSubExp :: KernelResult -> SubExp -kernelResultSubExp (Returns _ se) = se -kernelResultSubExp (WriteReturns _ arr _) = Var arr -kernelResultSubExp (ConcatReturns _ _ _ v) = Var v -kernelResultSubExp (TileReturns _ v) = Var v - -instance FreeIn KernelResult where - freeIn' (Returns _ what) = freeIn' what - freeIn' (WriteReturns rws arr res) = freeIn' rws <> freeIn' arr <> freeIn' res - freeIn' (ConcatReturns o w per_thread_elems v) = - freeIn' o <> freeIn' w <> freeIn' per_thread_elems <> freeIn' v - freeIn' (TileReturns dims v) = - freeIn' dims <> freeIn' v - -instance Attributes lore => FreeIn (KernelBody lore) where - freeIn' (KernelBody attr stms res) = - fvBind bound_in_stms $ freeIn' attr <> freeIn' stms <> freeIn' res - where bound_in_stms = foldMap boundByStm stms - -instance Attributes lore => Substitute (KernelBody lore) where - substituteNames subst (KernelBody attr stms res) = - KernelBody - (substituteNames subst attr) - (substituteNames subst stms) - (substituteNames subst res) - -instance Substitute KernelResult where - substituteNames subst (Returns manifest se) = - Returns manifest (substituteNames subst se) - substituteNames subst (WriteReturns rws arr res) = - WriteReturns - (substituteNames subst rws) (substituteNames subst arr) - (substituteNames subst res) - substituteNames subst (ConcatReturns o w per_thread_elems v) = - ConcatReturns - (substituteNames subst o) - (substituteNames subst w) - (substituteNames subst per_thread_elems) - (substituteNames subst v) - substituteNames subst (TileReturns dims v) = - TileReturns (substituteNames subst dims) (substituteNames subst v) - -instance Attributes lore => Rename (KernelBody lore) where - rename (KernelBody attr stms res) = do - attr' <- rename attr - renamingStms stms $ \stms' -> - KernelBody attr' stms' <$> rename res - -instance Rename KernelResult where - rename = substituteRename - --- | Perform alias analysis on a 'KernelBody'. -aliasAnalyseKernelBody :: (Attributes lore, - CanBeAliased (Op lore)) => - KernelBody lore - -> KernelBody (Aliases lore) -aliasAnalyseKernelBody (KernelBody attr stms res) = - let Body attr' stms' _ = Alias.analyseBody mempty $ Body attr stms [] - in KernelBody attr' stms' res - -removeKernelBodyAliases :: CanBeAliased (Op lore) => - KernelBody (Aliases lore) -> KernelBody lore -removeKernelBodyAliases (KernelBody (_, attr) stms res) = - KernelBody attr (fmap removeStmAliases stms) res - -addKernelBodyRanges :: (Attributes lore, CanBeRanged (Op lore)) => - KernelBody lore -> Range.RangeM (KernelBody (Ranges lore)) -addKernelBodyRanges (KernelBody attr stms res) = - Range.analyseStms stms $ \stms' -> do - let attr' = (mkBodyRanges stms $ map kernelResultSubExp res, attr) - return $ KernelBody attr' stms' res - -removeKernelBodyRanges :: CanBeRanged (Op lore) => - KernelBody (Ranges lore) -> KernelBody lore -removeKernelBodyRanges (KernelBody (_, attr) stms res) = - KernelBody attr (fmap removeStmRanges stms) res - -removeKernelBodyWisdom :: CanBeWise (Op lore) => - KernelBody (Wise lore) -> KernelBody lore -removeKernelBodyWisdom (KernelBody attr stms res) = - let Body attr' stms' _ = removeBodyWisdom $ Body attr stms [] - in KernelBody attr' stms' res - -consumedInKernelBody :: Aliased lore => - KernelBody lore -> Names -consumedInKernelBody (KernelBody attr stms res) = - consumedInBody (Body attr stms []) <> mconcat (map consumedByReturn res) - where consumedByReturn (WriteReturns _ a _) = oneName a - consumedByReturn _ = mempty - -checkKernelBody :: TC.Checkable lore => - [Type] -> KernelBody (Aliases lore) -> TC.TypeM lore () -checkKernelBody ts (KernelBody (_, attr) stms kres) = do - TC.checkBodyLore attr - TC.checkStms stms $ do - unless (length ts == length kres) $ - TC.bad $ TC.TypeError $ "Kernel return type is " ++ prettyTuple ts ++ - ", but body returns " ++ show (length kres) ++ " values." - zipWithM_ checkKernelResult kres ts - - where checkKernelResult (Returns _ what) t = - TC.require [t] what - checkKernelResult (WriteReturns rws arr res) t = do - mapM_ (TC.require [Prim int32]) rws - arr_t <- lookupType arr - forM_ res $ \(is, e) -> do - mapM_ (TC.require [Prim int32]) is - TC.require [t] e - unless (arr_t == t `arrayOfShape` Shape rws) $ - TC.bad $ TC.TypeError $ "WriteReturns returning " ++ - pretty e ++ " of type " ++ pretty t ++ ", shape=" ++ pretty rws ++ - ", but destination array has type " ++ pretty arr_t - TC.consume =<< TC.lookupAliases arr - checkKernelResult (ConcatReturns o w per_thread_elems v) t = do - case o of - SplitContiguous -> return () - SplitStrided stride -> TC.require [Prim int32] stride - TC.require [Prim int32] w - TC.require [Prim int32] per_thread_elems - vt <- lookupType v - unless (vt == t `arrayOfRow` arraySize 0 vt) $ - TC.bad $ TC.TypeError $ "Invalid type for ConcatReturns " ++ pretty v - checkKernelResult (TileReturns dims v) t = do - forM_ dims $ \(dim, tile) -> do - TC.require [Prim int32] dim - TC.require [Prim int32] tile - vt <- lookupType v - unless (vt == t `arrayOfShape` Shape (map snd dims)) $ - TC.bad $ TC.TypeError $ "Invalid type for TileReturns " ++ pretty v - -kernelBodyMetrics :: OpMetrics (Op lore) => KernelBody lore -> MetricsM () -kernelBodyMetrics = mapM_ bindingMetrics . kernelBodyStms - -instance PrettyLore lore => Pretty (KernelBody lore) where - ppr (KernelBody _ stms res) = - PP.stack (map ppr (stmsToList stms)) - text "return" <+> PP.braces (PP.commasep $ map ppr res) - -instance Pretty KernelResult where - ppr (Returns ResultNoSimplify what) = - text "returns (manifest)" <+> ppr what - ppr (Returns ResultPrivate what) = - text "returns (private)" <+> ppr what - ppr (Returns ResultMaySimplify what) = - text "returns" <+> ppr what - ppr (WriteReturns rws arr res) = - ppr arr <+> text "with" <+> PP.apply (map ppRes res) - where ppRes (is, e) = - PP.brackets (PP.commasep $ zipWith f is rws) <+> text "<-" <+> ppr e - f i rw = ppr i <+> text "<" <+> ppr rw - ppr (ConcatReturns o w per_thread_elems v) = - text "concat" <> suff <> - parens (commasep [ppr w, ppr per_thread_elems]) <+> ppr v - where suff = case o of SplitContiguous -> mempty - SplitStrided stride -> text "Strided" <> parens (ppr stride) - ppr (TileReturns dims v) = - text "tile" <> - parens (commasep $ map onDim dims) <+> ppr v - where onDim (dim, tile) = ppr dim <+> text "/" <+> ppr tile - - --- | Do we need group-virtualisation when generating code for the --- segmented operation? In most cases, we do, but for some simple --- kernels, we compute the full number of groups in advance, and then --- virtualisation is an unnecessary (but generally very small) --- overhead. This only really matters for fairly trivial but very --- wide @map@ kernels where each thread performs constant-time work on --- scalars. -data SegVirt - = SegVirt - | SegNoVirt - | SegNoVirtFull - -- ^ Not only do we not need virtualisation, but we _guarantee_ - -- that all physical threads participate in the work. This can - -- save some checks in code generation. - deriving (Eq, Ord, Show) - --- | Index space of a 'SegOp'. -data SegSpace = SegSpace { segFlat :: VName - -- ^ Flat physical index corresponding to the - -- dimensions (at code generation used for a - -- thread ID or similar). - , unSegSpace :: [(VName, SubExp)] - } - deriving (Eq, Ord, Show) - - --- | The sizes spanned by the indexes of the 'SegSpace'. -segSpaceDims :: SegSpace -> [SubExp] -segSpaceDims (SegSpace _ space) = map snd space - --- | A 'Scope' containing all the identifiers brought into scope by --- this 'SegSpace'. -scopeOfSegSpace :: SegSpace -> Scope lore -scopeOfSegSpace (SegSpace phys space) = - M.fromList $ zip (phys : map fst space) $ repeat $ IndexInfo Int32 - -checkSegSpace :: TC.Checkable lore => SegSpace -> TC.TypeM lore () -checkSegSpace (SegSpace _ dims) = - mapM_ (TC.require [Prim int32] . snd) dims - --- | A 'SegOp' is semantically a perfectly nested stack of maps, on --- top of some bottommost computation (scalar computation, reduction, --- scan, or histogram). The 'SegSpace' encodes the original map --- structure. --- --- All 'SegOps' are parameterised by the representation of their body, --- as well as a *level*. The *level* is a representation-specific bit --- of information. For example, in GPU backends, it is used to --- indicate whether the 'SegOp' is expected to run at the thread-level --- or the group-level. -data SegOp lvl lore - = SegMap lvl SegSpace [Type] (KernelBody lore) - | SegRed lvl SegSpace [SegBinOp lore] [Type] (KernelBody lore) - -- ^ The KernelSpace must always have at least two dimensions, - -- implying that the result of a SegRed is always an array. - | SegScan lvl SegSpace [SegBinOp lore] [Type] (KernelBody lore) - | SegHist lvl SegSpace [HistOp lore] [Type] (KernelBody lore) - deriving (Eq, Ord, Show) - --- | The level of a 'SegOp'. -segLevel :: SegOp lvl lore -> lvl -segLevel (SegMap lvl _ _ _) = lvl -segLevel (SegRed lvl _ _ _ _) = lvl -segLevel (SegScan lvl _ _ _ _) = lvl -segLevel (SegHist lvl _ _ _ _) = lvl - --- | The space of a 'SegOp'. -segSpace :: SegOp lvl lore -> SegSpace -segSpace (SegMap _ lvl _ _) = lvl -segSpace (SegRed _ lvl _ _ _) = lvl -segSpace (SegScan _ lvl _ _ _) = lvl -segSpace (SegHist _ lvl _ _ _) = lvl - -segResultShape :: SegSpace -> Type -> KernelResult -> Type -segResultShape _ t (WriteReturns rws _ _) = - t `arrayOfShape` Shape rws -segResultShape space t (Returns _ _) = - foldr (flip arrayOfRow) t $ segSpaceDims space -segResultShape _ t (ConcatReturns _ w _ _) = - t `arrayOfRow` w -segResultShape _ t (TileReturns dims _) = - t `arrayOfShape` Shape (map fst dims) - --- | The return type of a 'SegOp'. -segOpType :: SegOp lvl lore -> [Type] -segOpType (SegMap _ space ts kbody) = - zipWith (segResultShape space) ts $ kernelBodyResult kbody -segOpType (SegRed _ space reds ts kbody) = - red_ts ++ - zipWith (segResultShape space) map_ts - (drop (length red_ts) $ kernelBodyResult kbody) - where map_ts = drop (length red_ts) ts - segment_dims = init $ segSpaceDims space - red_ts = do - op <- reds - let shape = Shape segment_dims <> segBinOpShape op - map (`arrayOfShape` shape) (lambdaReturnType $ segBinOpLambda op) -segOpType (SegScan _ space scans ts kbody) = - scan_ts ++ - zipWith (segResultShape space) map_ts - (drop (length scan_ts) $ kernelBodyResult kbody) - where map_ts = drop (length scan_ts) ts - scan_ts = do - op <- scans - let shape = Shape (segSpaceDims space) <> segBinOpShape op - map (`arrayOfShape` shape) (lambdaReturnType $ segBinOpLambda op) -segOpType (SegHist _ space ops _ _) = do - op <- ops - let shape = Shape (segment_dims <> [histWidth op]) <> histShape op - map (`arrayOfShape` shape) (lambdaReturnType $ histOp op) - where dims = segSpaceDims space - segment_dims = init dims - -instance TypedOp (SegOp lvl lore) where - opType = pure . staticShapes . segOpType - -instance (Attributes lore, Aliased lore, ASTConstraints lvl) => - AliasedOp (SegOp lvl lore) where - opAliases = map (const mempty) . segOpType - - consumedInOp (SegMap _ _ _ kbody) = - consumedInKernelBody kbody - consumedInOp (SegRed _ _ _ _ kbody) = - consumedInKernelBody kbody - consumedInOp (SegScan _ _ _ _ kbody) = - consumedInKernelBody kbody - consumedInOp (SegHist _ _ ops _ kbody) = - namesFromList (concatMap histDest ops) <> consumedInKernelBody kbody - --- | Type check a 'SegOp', given a checker for its level. -typeCheckSegOp :: TC.Checkable lore => - (lvl -> TC.TypeM lore ()) - -> SegOp lvl (Aliases lore) -> TC.TypeM lore () -typeCheckSegOp checkLvl (SegMap lvl space ts kbody) = do - checkLvl lvl - checkScanRed space [] ts kbody - -typeCheckSegOp checkLvl (SegRed lvl space reds ts body) = do - checkLvl lvl - checkScanRed space reds' ts body - where reds' = zip3 - (map segBinOpLambda reds) - (map segBinOpNeutral reds) - (map segBinOpShape reds) - -typeCheckSegOp checkLvl (SegScan lvl space scans ts body) = do - checkLvl lvl - checkScanRed space scans' ts body - where scans' = zip3 - (map segBinOpLambda scans) - (map segBinOpNeutral scans) - (map segBinOpShape scans) - -typeCheckSegOp checkLvl (SegHist lvl space ops ts kbody) = do - checkLvl lvl - checkSegSpace space - mapM_ TC.checkType ts - - TC.binding (scopeOfSegSpace space) $ do - nes_ts <- forM ops $ \(HistOp dest_w rf dests nes shape op) -> do - TC.require [Prim int32] dest_w - TC.require [Prim int32] rf - nes' <- mapM TC.checkArg nes - mapM_ (TC.require [Prim int32]) $ shapeDims shape - - -- Operator type must match the type of neutral elements. - let stripVecDims = stripArray $ shapeRank shape - TC.checkLambda op $ map (TC.noArgAliases . first stripVecDims) $ nes' ++ nes' - let nes_t = map TC.argType nes' - unless (nes_t == lambdaReturnType op) $ - TC.bad $ TC.TypeError $ "SegHist operator has return type " ++ - prettyTuple (lambdaReturnType op) ++ " but neutral element has type " ++ - prettyTuple nes_t - - -- Arrays must have proper type. - let dest_shape = Shape (segment_dims <> [dest_w]) <> shape - forM_ (zip nes_t dests) $ \(t, dest) -> do - TC.requireI [t `arrayOfShape` dest_shape] dest - TC.consume =<< TC.lookupAliases dest - - return $ map (`arrayOfShape` shape) nes_t - - checkKernelBody ts kbody - - -- Return type of bucket function must be an index for each - -- operation followed by the values to write. - let bucket_ret_t = replicate (length ops) (Prim int32) ++ concat nes_ts - unless (bucket_ret_t == ts) $ - TC.bad $ TC.TypeError $ "SegHist body has return type " ++ - prettyTuple ts ++ " but should have type " ++ - prettyTuple bucket_ret_t - - where segment_dims = init $ segSpaceDims space - -checkScanRed :: TC.Checkable lore => - SegSpace - -> [(Lambda (Aliases lore), [SubExp], Shape)] - -> [Type] - -> KernelBody (Aliases lore) - -> TC.TypeM lore () -checkScanRed space ops ts kbody = do - checkSegSpace space - mapM_ TC.checkType ts - - TC.binding (scopeOfSegSpace space) $ do - ne_ts <- forM ops $ \(lam, nes, shape) -> do - mapM_ (TC.require [Prim int32]) $ shapeDims shape - nes' <- mapM TC.checkArg nes - - -- Operator type must match the type of neutral elements. - TC.checkLambda lam $ map TC.noArgAliases $ nes' ++ nes' - let nes_t = map TC.argType nes' - - unless (lambdaReturnType lam == nes_t) $ - TC.bad $ TC.TypeError "wrong type for operator or neutral elements." - - return $ map (`arrayOfShape` shape) nes_t - - let expecting = concat ne_ts - got = take (length expecting) ts - unless (expecting == got) $ - TC.bad $ TC.TypeError $ - "Wrong return for body (does not match neutral elements; expected " ++ - pretty expecting ++ "; found " ++ - pretty got ++ ")" - - checkKernelBody ts kbody - --- | Like 'Mapper', but just for 'SegOp's. -data SegOpMapper lvl flore tlore m = SegOpMapper { - mapOnSegOpSubExp :: SubExp -> m SubExp - , mapOnSegOpLambda :: Lambda flore -> m (Lambda tlore) - , mapOnSegOpBody :: KernelBody flore -> m (KernelBody tlore) - , mapOnSegOpVName :: VName -> m VName - , mapOnSegOpLevel :: lvl -> m lvl - } - --- | A mapper that simply returns the 'SegOp' verbatim. -identitySegOpMapper :: Monad m => SegOpMapper lvl lore lore m -identitySegOpMapper = SegOpMapper { mapOnSegOpSubExp = return - , mapOnSegOpLambda = return - , mapOnSegOpBody = return - , mapOnSegOpVName = return - , mapOnSegOpLevel = return - } - -mapOnSegSpace :: Monad f => - SegOpMapper lvl flore tlore f -> SegSpace -> f SegSpace -mapOnSegSpace tv (SegSpace phys dims) = - SegSpace phys <$> traverse (traverse $ mapOnSegOpSubExp tv) dims - -mapSegBinOp :: Monad m => - SegOpMapper lvl flore tlore m - -> SegBinOp flore -> m (SegBinOp tlore) -mapSegBinOp tv (SegBinOp comm red_op nes shape) = - SegBinOp comm - <$> mapOnSegOpLambda tv red_op - <*> mapM (mapOnSegOpSubExp tv) nes - <*> (Shape <$> mapM (mapOnSegOpSubExp tv) (shapeDims shape)) - -mapSegOpM :: (Applicative m, Monad m) => - SegOpMapper lvl flore tlore m - -> SegOp lvl flore -> m (SegOp lvl tlore) -mapSegOpM tv (SegMap lvl space ts body) = - SegMap - <$> mapOnSegOpLevel tv lvl - <*> mapOnSegSpace tv space - <*> mapM (mapOnSegOpType tv) ts - <*> mapOnSegOpBody tv body -mapSegOpM tv (SegRed lvl space reds ts lam) = - SegRed - <$> mapOnSegOpLevel tv lvl - <*> mapOnSegSpace tv space - <*> mapM (mapSegBinOp tv) reds - <*> mapM (mapOnType $ mapOnSegOpSubExp tv) ts - <*> mapOnSegOpBody tv lam -mapSegOpM tv (SegScan lvl space scans ts body) = - SegScan - <$> mapOnSegOpLevel tv lvl - <*> mapOnSegSpace tv space - <*> mapM (mapSegBinOp tv) scans - <*> mapM (mapOnType $ mapOnSegOpSubExp tv) ts - <*> mapOnSegOpBody tv body -mapSegOpM tv (SegHist lvl space ops ts body) = - SegHist - <$> mapOnSegOpLevel tv lvl - <*> mapOnSegSpace tv space - <*> mapM onHistOp ops - <*> mapM (mapOnType $ mapOnSegOpSubExp tv) ts - <*> mapOnSegOpBody tv body - where onHistOp (HistOp w rf arrs nes shape op) = - HistOp <$> mapOnSegOpSubExp tv w - <*> mapOnSegOpSubExp tv rf - <*> mapM (mapOnSegOpVName tv) arrs - <*> mapM (mapOnSegOpSubExp tv) nes - <*> (Shape <$> mapM (mapOnSegOpSubExp tv) (shapeDims shape)) - <*> mapOnSegOpLambda tv op - -mapOnSegOpType :: Monad m => - SegOpMapper lvl flore tlore m -> Type -> m Type -mapOnSegOpType _tv (Prim pt) = pure $ Prim pt -mapOnSegOpType tv (Array pt shape u) = Array pt <$> f shape <*> pure u - where f (Shape dims) = Shape <$> mapM (mapOnSegOpSubExp tv) dims -mapOnSegOpType _tv (Mem s) = pure $ Mem s - -instance (Attributes lore, Substitute lvl) => - Substitute (SegOp lvl lore) where - substituteNames subst = runIdentity . mapSegOpM substitute - where substitute = - SegOpMapper { mapOnSegOpSubExp = return . substituteNames subst - , mapOnSegOpLambda = return . substituteNames subst - , mapOnSegOpBody = return . substituteNames subst - , mapOnSegOpVName = return . substituteNames subst - , mapOnSegOpLevel = return . substituteNames subst - } - -instance (Attributes lore, ASTConstraints lvl) => - Rename (SegOp lvl lore) where - rename = mapSegOpM renamer - where renamer = SegOpMapper rename rename rename rename rename - -instance (Attributes lore, FreeIn (LParamAttr lore), FreeIn lvl) => - FreeIn (SegOp lvl lore) where - freeIn' e = flip execState mempty $ mapSegOpM free e - where walk f x = modify (<>f x) >> return x - free = SegOpMapper { mapOnSegOpSubExp = walk freeIn' - , mapOnSegOpLambda = walk freeIn' - , mapOnSegOpBody = walk freeIn' - , mapOnSegOpVName = walk freeIn' - , mapOnSegOpLevel = walk freeIn' - } - -instance OpMetrics (Op lore) => OpMetrics (SegOp lvl lore) where - opMetrics (SegMap _ _ _ body) = - inside "SegMap" $ kernelBodyMetrics body - opMetrics (SegRed _ _ reds _ body) = - inside "SegRed" $ do mapM_ (lambdaMetrics . segBinOpLambda) reds - kernelBodyMetrics body - opMetrics (SegScan _ _ scans _ body) = - inside "SegScan" $ do mapM_ (lambdaMetrics . segBinOpLambda) scans - kernelBodyMetrics body - opMetrics (SegHist _ _ ops _ body) = - inside "SegHist" $ do mapM_ (lambdaMetrics . histOp) ops - kernelBodyMetrics body - -instance Pretty SegSpace where - ppr (SegSpace phys dims) = parens (commasep $ do (i,d) <- dims - return $ ppr i <+> "<" <+> ppr d) <+> - parens (text "~" <> ppr phys) - -instance PrettyLore lore => Pretty (SegBinOp lore) where - ppr (SegBinOp comm lam nes shape) = - PP.braces (PP.commasep $ map ppr nes) <> PP.comma - ppr shape <> PP.comma - comm' <> ppr lam - where comm' = case comm of Commutative -> text "commutative " - Noncommutative -> mempty - -instance (PrettyLore lore, PP.Pretty lvl) => PP.Pretty (SegOp lvl lore) where - ppr (SegMap lvl space ts body) = - text "segmap" <> ppr lvl - PP.align (ppr space) <+> - PP.colon <+> ppTuple' ts <+> PP.nestedBlock "{" "}" (ppr body) - - ppr (SegRed lvl space reds ts body) = - text "segred" <> ppr lvl - PP.parens (PP.braces (mconcat $ intersperse (PP.comma <> PP.line) $ map ppr reds)) - PP.align (ppr space) <+> PP.colon <+> ppTuple' ts <+> - PP.nestedBlock "{" "}" (ppr body) - - ppr (SegScan lvl space scans ts body) = - text "segscan" <> ppr lvl - PP.parens (PP.braces (mconcat $ intersperse (PP.comma <> PP.line) $ map ppr scans)) - PP.align (ppr space) <+> PP.colon <+> ppTuple' ts <+> - PP.nestedBlock "{" "}" (ppr body) - - ppr (SegHist lvl space ops ts body) = - text "seghist" <> ppr lvl - ppr lvl - PP.parens (PP.braces (mconcat $ intersperse (PP.comma <> PP.line) $ map ppOp ops)) - PP.align (ppr space) <+> PP.colon <+> ppTuple' ts <+> - PP.nestedBlock "{" "}" (ppr body) - where ppOp (HistOp w rf dests nes shape op) = - ppr w <> PP.comma <+> ppr rf <> PP.comma - PP.braces (PP.commasep $ map ppr dests) <> PP.comma - PP.braces (PP.commasep $ map ppr nes) <> PP.comma - ppr shape <> PP.comma - ppr op - -instance (Attributes inner, ASTConstraints lvl) => - RangedOp (SegOp lvl inner) where - opRanges op = replicate (length $ segOpType op) unknownRange - -instance (Attributes lore, CanBeRanged (Op lore), ASTConstraints lvl) => - CanBeRanged (SegOp lvl lore) where - type OpWithRanges (SegOp lvl lore) = SegOp lvl (Ranges lore) - - removeOpRanges = runIdentity . mapSegOpM remove - where remove = SegOpMapper return (return . removeLambdaRanges) - (return . removeKernelBodyRanges) return return - addOpRanges = Range.runRangeM . mapSegOpM add - where add = SegOpMapper return Range.analyseLambda - addKernelBodyRanges return return - -instance (Attributes lore, Attributes (Aliases lore), - CanBeAliased (Op lore), ASTConstraints lvl) => - CanBeAliased (SegOp lvl lore) where - type OpWithAliases (SegOp lvl lore) = SegOp lvl (Aliases lore) - - addOpAliases = runIdentity . mapSegOpM alias - where alias = SegOpMapper return (return . Alias.analyseLambda) - (return . aliasAnalyseKernelBody) return return - - removeOpAliases = runIdentity . mapSegOpM remove - where remove = SegOpMapper return (return . removeLambdaAliases) - (return . removeKernelBodyAliases) return return - -instance (CanBeWise (Op lore), Attributes lore, ASTConstraints lvl) => - CanBeWise (SegOp lvl lore) where - type OpWithWisdom (SegOp lvl lore) = SegOp lvl (Wise lore) - - removeOpWisdom = runIdentity . mapSegOpM remove - where remove = SegOpMapper return - (return . removeLambdaWisdom) - (return . removeKernelBodyWisdom) - return return - -instance Attributes lore => ST.IndexOp (SegOp lvl lore) where - indexOp vtable k (SegMap _ space _ kbody) is = do - Returns ResultMaySimplify se <- maybeNth k $ kernelBodyResult kbody - guard $ length gtids <= length is - let idx_table = M.fromList $ zip gtids $ map (ST.Indexed mempty) is - idx_table' = foldl expandIndexedTable idx_table $ kernelBodyStms kbody - case se of - Var v -> M.lookup v idx_table' - _ -> Nothing - - where (gtids, _) = unzip $ unSegSpace space - -- Indexes in excess of what is used to index through the - -- segment dimensions. - excess_is = drop (length gtids) is - - expandIndexedTable table stm - | [v] <- patternNames $ stmPattern stm, - Just (pe,cs) <- - runWriterT $ primExpFromExp (asPrimExp table) $ stmExp stm = - M.insert v (ST.Indexed (stmCerts stm <> cs) pe) table - - | [v] <- patternNames $ stmPattern stm, - BasicOp (Index arr slice) <- stmExp stm, - length (sliceDims slice) == length excess_is, - arr `ST.elem` vtable, - Just (slice', cs) <- asPrimExpSlice table slice = - let idx = ST.IndexedArray (stmCerts stm <> cs) - arr (fixSlice slice' excess_is) - in M.insert v idx table - - | otherwise = - table - - asPrimExpSlice table = - runWriterT . mapM (traverse (primExpFromSubExpM (asPrimExp table))) - - asPrimExp table v - | Just (ST.Indexed cs e) <- M.lookup v table = tell cs >> return e - | Just (Prim pt) <- ST.lookupType v vtable = - return $ LeafExp v pt - | otherwise = lift Nothing - - indexOp _ _ _ _ = Nothing - -instance (Attributes lore, ASTConstraints lvl) => - IsOp (SegOp lvl lore) where - cheapOp _ = False - safeOp _ = True - ---- Simplification - -instance Engine.Simplifiable SplitOrdering where - simplify SplitContiguous = - return SplitContiguous - simplify (SplitStrided stride) = - SplitStrided <$> Engine.simplify stride - -instance Engine.Simplifiable SegSpace where - simplify (SegSpace phys dims) = - SegSpace phys <$> mapM (traverse Engine.simplify) dims - -instance Engine.Simplifiable KernelResult where - simplify (Returns manifest what) = - Returns manifest <$> Engine.simplify what - simplify (WriteReturns ws a res) = - WriteReturns <$> Engine.simplify ws <*> Engine.simplify a <*> Engine.simplify res - simplify (ConcatReturns o w pte what) = - ConcatReturns - <$> Engine.simplify o - <*> Engine.simplify w - <*> Engine.simplify pte - <*> Engine.simplify what - simplify (TileReturns dims what) = - TileReturns <$> Engine.simplify dims <*> Engine.simplify what - -mkWiseKernelBody :: (Attributes lore, CanBeWise (Op lore)) => - BodyAttr lore -> Stms (Wise lore) -> [KernelResult] -> KernelBody (Wise lore) -mkWiseKernelBody attr bnds res = - let Body attr' _ _ = mkWiseBody attr bnds res_vs - in KernelBody attr' bnds res - where res_vs = map kernelResultSubExp res - -mkKernelBodyM :: MonadBinder m => - Stms (Lore m) -> [KernelResult] - -> m (KernelBody (Lore m)) -mkKernelBodyM stms kres = do - Body attr' _ _ <- mkBodyM stms res_ses - return $ KernelBody attr' stms kres - where res_ses = map kernelResultSubExp kres - -simplifyKernelBody :: (Engine.SimplifiableLore lore, BodyAttr lore ~ ()) => - SegSpace -> KernelBody lore - -> Engine.SimpleM lore (KernelBody (Wise lore), Stms (Wise lore)) -simplifyKernelBody space (KernelBody _ stms res) = do - par_blocker <- Engine.asksEngineEnv $ Engine.blockHoistPar . Engine.envHoistBlockers - - ((body_stms, body_res), hoisted) <- - Engine.localVtable (<>scope_vtable) $ - Engine.localVtable (\vtable -> vtable { ST.simplifyMemory = True }) $ - Engine.blockIf (Engine.hasFree bound_here - `Engine.orIf` Engine.isOp - `Engine.orIf` par_blocker - `Engine.orIf` Engine.isConsumed) $ - Engine.simplifyStms stms $ do - res' <- Engine.localVtable (ST.hideCertified $ namesFromList $ M.keys $ scopeOf stms) $ - mapM Engine.simplify res - return ((res', UT.usages $ freeIn res'), mempty) - - return (mkWiseKernelBody () body_stms body_res, hoisted) - - where scope_vtable = ST.fromScope $ scopeOfSegSpace space - bound_here = namesFromList $ M.keys $ scopeOfSegSpace space - -simplifySegBinOp :: Engine.SimplifiableLore lore => - SegBinOp lore - -> Engine.SimpleM lore (SegBinOp (Wise lore), Stms (Wise lore)) -simplifySegBinOp (SegBinOp comm lam nes shape) = do - (lam', hoisted) <- - Engine.localVtable (\vtable -> vtable { ST.simplifyMemory = True }) $ - Engine.simplifyLambda lam $ replicate (length nes * 2) Nothing - shape' <- Engine.simplify shape - nes' <- mapM Engine.simplify nes - return (SegBinOp comm lam' nes' shape', hoisted) - -simplifySegOp :: (Engine.SimplifiableLore lore, - BodyAttr lore ~ (), - Engine.Simplifiable lvl) => - SegOp lvl lore - -> Engine.SimpleM lore (SegOp lvl (Wise lore), Stms (Wise lore)) -simplifySegOp (SegMap lvl space ts kbody) = do - (lvl', space', ts') <- Engine.simplify (lvl, space, ts) - (kbody', body_hoisted) <- simplifyKernelBody space kbody - return (SegMap lvl' space' ts' kbody', - body_hoisted) - -simplifySegOp (SegRed lvl space reds ts kbody) = do - (lvl', space', ts') <- Engine.simplify (lvl, space, ts) - (reds', reds_hoisted) <- Engine.localVtable (<>scope_vtable) $ - unzip <$> mapM simplifySegBinOp reds - (kbody', body_hoisted) <- simplifyKernelBody space kbody - - return (SegRed lvl' space' reds' ts' kbody', - mconcat reds_hoisted <> body_hoisted) - where scope = scopeOfSegSpace space - scope_vtable = ST.fromScope scope - -simplifySegOp (SegScan lvl space scans ts kbody) = do - (lvl', space', ts') <- Engine.simplify (lvl, space, ts) - (scans', scans_hoisted) <- Engine.localVtable (<>scope_vtable) $ - unzip <$> mapM simplifySegBinOp scans - (kbody', body_hoisted) <- simplifyKernelBody space kbody - - return (SegScan lvl' space' scans' ts' kbody', - mconcat scans_hoisted <> body_hoisted) - where scope = scopeOfSegSpace space - scope_vtable = ST.fromScope scope - -simplifySegOp (SegHist lvl space ops ts kbody) = do - (lvl', space', ts') <- Engine.simplify (lvl, space, ts) - - (ops', ops_hoisted) <- fmap unzip $ forM ops $ - \(HistOp w rf arrs nes dims lam) -> do - w' <- Engine.simplify w - rf' <- Engine.simplify rf - arrs' <- Engine.simplify arrs - nes' <- Engine.simplify nes - dims' <- Engine.simplify dims - (lam', op_hoisted) <- - Engine.localVtable (<>scope_vtable) $ - Engine.localVtable (\vtable -> vtable { ST.simplifyMemory = True }) $ - Engine.simplifyLambda lam $ - replicate (length nes * 2) Nothing - return (HistOp w' rf' arrs' nes' dims' lam', - op_hoisted) - - (kbody', body_hoisted) <- simplifyKernelBody space kbody - - return (SegHist lvl' space' ops' ts' kbody', - mconcat ops_hoisted <> body_hoisted) - - where scope = scopeOfSegSpace space - scope_vtable = ST.fromScope scope - --- | Does this lore contain 'SegOp's in its 'Op's? A lore must be an --- instance of this class for the simplification rules to work. -class HasSegOp lore where - type SegOpLevel lore - asSegOp :: Op lore -> Maybe (SegOp (SegOpLevel lore) lore) - segOp :: SegOp (SegOpLevel lore) lore -> Op lore - --- | Simplification rules for simplifying 'SegOp's. -segOpRules :: (HasSegOp lore, BinderOps lore, Bindable lore) => - RuleBook lore -segOpRules = - ruleBook [ RuleOp segOpRuleTopDown ] [ RuleOp segOpRuleBottomUp ] - -segOpRuleTopDown :: (HasSegOp lore, BinderOps lore, Bindable lore) => - TopDownRuleOp lore -segOpRuleTopDown vtable pat attr op - | Just op' <- asSegOp op = - topDownSegOp vtable pat attr op' - | otherwise = - Skip - -segOpRuleBottomUp :: (HasSegOp lore, BinderOps lore) => - BottomUpRuleOp lore -segOpRuleBottomUp vtable pat attr op - | Just op' <- asSegOp op = - bottomUpSegOp vtable pat attr op' - | otherwise = - Skip - -topDownSegOp :: (HasSegOp lore, BinderOps lore, Bindable lore) => - ST.SymbolTable lore - -> Pattern lore - -> StmAux (ExpAttr lore) - -> SegOp (SegOpLevel lore) lore - -> Rule lore - --- If a SegOp produces something invariant to the SegOp, turn it --- into a replicate. -topDownSegOp vtable (Pattern [] kpes) attr (SegMap lvl space ts (KernelBody _ kstms kres)) = Simplify $ do - (ts', kpes', kres') <- - unzip3 <$> filterM checkForInvarianceResult (zip3 ts kpes kres) - - -- Check if we did anything at all. - when (kres == kres') - cannotSimplify - - kbody <- mkKernelBodyM kstms kres' - addStm $ Let (Pattern [] kpes') attr $ Op $ segOp $ - SegMap lvl space ts' kbody - - where isInvariant Constant{} = True - isInvariant (Var v) = isJust $ ST.lookup v vtable - - checkForInvarianceResult (_, pe, Returns rm se) - | rm == ResultMaySimplify, - isInvariant se = do - letBindNames_ [patElemName pe] $ - BasicOp $ Replicate (Shape $ segSpaceDims space) se - return False - checkForInvarianceResult _ = - return True - --- If a SegRed contains two reduction operations that have the same --- vector shape, merge them together. This saves on communication --- overhead, but can in principle lead to more local memory usage. -topDownSegOp _ (Pattern [] pes) _ (SegRed lvl space ops ts kbody) - | length ops > 1, - op_groupings <- groupBy sameShape $ zip ops $ chunks (map (length . segBinOpNeutral) ops) $ - zip3 red_pes red_ts red_res, - any ((>1) . length) op_groupings = Simplify $ do - let (ops', aux) = unzip $ mapMaybe combineOps op_groupings - (red_pes', red_ts', red_res') = unzip3 $ concat aux - pes' = red_pes' ++ map_pes - ts' = red_ts' ++ map_ts - kbody' = kbody { kernelBodyResult = red_res' ++ map_res } - letBind_ (Pattern [] pes') $ Op $ segOp $ SegRed lvl space ops' ts' kbody' - where (red_pes, map_pes) = splitAt (segBinOpResults ops) pes - (red_ts, map_ts) = splitAt (segBinOpResults ops) ts - (red_res, map_res) = splitAt (segBinOpResults ops) $ kernelBodyResult kbody - - sameShape (op1, _) (op2, _) = segBinOpShape op1 == segBinOpShape op2 - - combineOps [] = Nothing - combineOps (x:xs) = Just $ foldl' combine x xs - - combine (op1, op1_aux) (op2, op2_aux) = - let lam1 = segBinOpLambda op1 - lam2 = segBinOpLambda op2 - (op1_xparams, op1_yparams) = - splitAt (length (segBinOpNeutral op1)) $ lambdaParams lam1 - (op2_xparams, op2_yparams) = - splitAt (length (segBinOpNeutral op2)) $ lambdaParams lam2 - lam = Lambda { lambdaParams = op1_xparams ++ op2_xparams ++ - op1_yparams ++ op2_yparams - , lambdaReturnType = lambdaReturnType lam1 ++ lambdaReturnType lam2 - , lambdaBody = - mkBody (bodyStms (lambdaBody lam1) <> bodyStms (lambdaBody lam2)) $ - bodyResult (lambdaBody lam1) <> bodyResult (lambdaBody lam2) - } - in (SegBinOp { segBinOpComm = segBinOpComm op1 <> segBinOpComm op2 - , segBinOpLambda = lam - , segBinOpNeutral = segBinOpNeutral op1 ++ segBinOpNeutral op2 - , segBinOpShape = segBinOpShape op1 -- Same as shape of op2 due to the grouping. - }, - op1_aux ++ op2_aux) -topDownSegOp _ _ _ _ = Skip - -bottomUpSegOp :: (HasSegOp lore, BinderOps lore) => - (ST.SymbolTable lore, UT.UsageTable) - -> Pattern lore - -> StmAux (ExpAttr lore) - -> SegOp (SegOpLevel lore) lore - -> Rule lore - --- Some SegOp results can be moved outside the SegOp, which can --- simplify further analysis. -bottomUpSegOp (vtable, used) (Pattern [] kpes) attr (SegMap lvl space kts (KernelBody _ kstms kres)) = Simplify $ do - - -- Iterate through the bindings. For each, we check whether it is - -- in kres and can be moved outside. If so, we remove it from kres - -- and kpes and make it a binding outside. - (kpes', kts', kres', kstms') <- localScope (scopeOfSegSpace space) $ - foldM distribute (kpes, kts, kres, mempty) kstms - - when (kpes' == kpes) - cannotSimplify - - kbody <- localScope (scopeOfSegSpace space) $ - mkKernelBodyM kstms' kres' - - addStm $ Let (Pattern [] kpes') attr $ Op $ segOp $ - SegMap lvl space kts' kbody - where - free_in_kstms = foldMap freeIn kstms - - sliceWithGtidsFixed stm - | Let _ _ (BasicOp (Index arr slice)) <- stm, - space_slice <- map (DimFix . Var . fst) $ unSegSpace space, - space_slice `isPrefixOf` slice, - remaining_slice <- drop (length space_slice) slice, - all (isJust . flip ST.lookup vtable) $ namesToList $ - freeIn arr <> freeIn remaining_slice = - Just (remaining_slice, arr) - - | otherwise = - Nothing - - distribute (kpes', kts', kres', kstms') stm - | Let (Pattern [] [pe]) _ _ <- stm, - Just (remaining_slice, arr) <- sliceWithGtidsFixed stm, - Just (kpe, kpes'', kts'', kres'') <- isResult kpes' kts' kres' pe = do - let outer_slice = map (\d -> DimSlice - (constant (0::Int32)) - d - (constant (1::Int32))) $ - segSpaceDims space - index kpe' = letBind_ (Pattern [] [kpe']) $ BasicOp $ Index arr $ - outer_slice <> remaining_slice - if patElemName kpe `UT.isConsumed` used - then do precopy <- newVName $ baseString (patElemName kpe) <> "_precopy" - index kpe { patElemName = precopy } - letBind_ (Pattern [] [kpe]) $ BasicOp $ Copy precopy - else index kpe - return (kpes'', kts'', kres'', - if patElemName pe `nameIn` free_in_kstms - then kstms' <> oneStm stm - else kstms') - - distribute (kpes', kts', kres', kstms') stm = - return (kpes', kts', kres', kstms' <> oneStm stm) - - isResult kpes' kts' kres' pe = - case partition matches $ zip3 kpes' kts' kres' of - ([(kpe,_,_)], kpes_and_kres) - | (kpes'', kts'', kres'') <- unzip3 kpes_and_kres -> - Just (kpe, kpes'', kts'', kres'') - _ -> Nothing - where matches (_, _, Returns _ (Var v)) = v == patElemName pe - matches _ = False -bottomUpSegOp _ _ _ _ = Skip - ---- Memory - -kernelBodyReturns :: (Mem lore, HasScope lore m, Monad m) => - KernelBody lore -> [ExpReturns] -> m [ExpReturns] -kernelBodyReturns = zipWithM correct . kernelBodyResult - where correct (WriteReturns _ arr _) _ = varReturns arr - correct _ ret = return ret - --- | Like 'segOpType', but for memory representations. -segOpReturns :: (Mem lore, Monad m, HasScope lore m) => - SegOp lvl lore -> m [ExpReturns] -segOpReturns k@(SegMap _ _ _ kbody) = - kernelBodyReturns kbody =<< (extReturns <$> opType k) -segOpReturns k@(SegRed _ _ _ _ kbody) = - kernelBodyReturns kbody =<< (extReturns <$> opType k) -segOpReturns k@(SegScan _ _ _ _ kbody) = - kernelBodyReturns kbody =<< (extReturns <$> opType k) -segOpReturns (SegHist _ _ ops _ _) = - concat <$> mapM (mapM varReturns . histDest) ops diff --git a/src/Futhark/Representation/Seq.hs b/src/Futhark/Representation/Seq.hs deleted file mode 100644 --- a/src/Futhark/Representation/Seq.hs +++ /dev/null @@ -1,67 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} --- | A sequential representation. -module Futhark.Representation.Seq - ( -- * The Lore definition - Seq - - -- * Simplification - , simplifyProg - - -- * Module re-exports - , module Futhark.Representation.AST.Attributes - , module Futhark.Representation.AST.Traversals - , module Futhark.Representation.AST.Pretty - , module Futhark.Representation.AST.Syntax - ) -where - -import Futhark.Pass -import Futhark.Representation.AST.Syntax -import Futhark.Representation.AST.Attributes -import Futhark.Representation.AST.Traversals -import Futhark.Representation.AST.Pretty -import Futhark.Binder -import Futhark.Construct -import qualified Futhark.TypeCheck as TypeCheck -import qualified Futhark.Optimise.Simplify.Engine as Engine -import qualified Futhark.Optimise.Simplify as Simplify -import Futhark.Optimise.Simplify.Rules - -data Seq - -instance Annotations Seq where - type Op Seq = () - -instance Attributes Seq where - expTypesFromPattern = return . expExtTypesFromPattern - -instance TypeCheck.CheckableOp Seq where - checkOp = pure - -instance TypeCheck.Checkable Seq where - -instance Bindable Seq where - mkBody = Body () - mkExpPat ctx val _ = basicPattern ctx val - mkExpAttr _ _ = () - mkLetNames = simpleMkLetNames - -instance BinderOps Seq where - mkExpAttrB = bindableMkExpAttrB - mkBodyB = bindableMkBodyB - mkLetNamesB = bindableMkLetNamesB - -instance PrettyLore Seq where - -instance BinderOps (Engine.Wise Seq) where - mkExpAttrB = bindableMkExpAttrB - mkBodyB = bindableMkBodyB - mkLetNamesB = bindableMkLetNamesB - -simpleSeq :: Simplify.SimpleOps Seq -simpleSeq = Simplify.bindableSimpleOps (const $ pure ((), mempty)) - -simplifyProg :: Prog Seq -> PassM (Prog Seq) -simplifyProg = Simplify.simplifyProg simpleSeq standardRules blockers - where blockers = Engine.noExtraHoistBlockers diff --git a/src/Futhark/Representation/SeqMem.hs b/src/Futhark/Representation/SeqMem.hs deleted file mode 100644 --- a/src/Futhark/Representation/SeqMem.hs +++ /dev/null @@ -1,83 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ConstraintKinds #-} -module Futhark.Representation.SeqMem - ( SeqMem - - -- * Simplification - , simplifyProg - , simpleSeqMem - - -- * Module re-exports - , module Futhark.Representation.Mem - , module Futhark.Representation.Kernels.Kernel - ) - where - -import Futhark.Analysis.PrimExp.Convert -import Futhark.Pass -import Futhark.Representation.AST.Syntax -import Futhark.Representation.AST.Attributes -import Futhark.Representation.AST.Traversals -import Futhark.Representation.AST.Pretty -import Futhark.Representation.Kernels.Kernel -import qualified Futhark.TypeCheck as TC -import Futhark.Representation.Mem -import Futhark.Representation.Mem.Simplify -import Futhark.Pass.ExplicitAllocations (BinderOps(..), mkLetNamesB', mkLetNamesB'') -import qualified Futhark.Optimise.Simplify.Engine as Engine - -data SeqMem - -instance Annotations SeqMem where - type LetAttr SeqMem = LetAttrMem - type FParamAttr SeqMem = FParamMem - type LParamAttr SeqMem = LParamMem - type RetType SeqMem = RetTypeMem - type BranchType SeqMem = BranchTypeMem - type Op SeqMem = MemOp () - -instance Attributes SeqMem where - expTypesFromPattern = return . map snd . snd . bodyReturnsFromPattern - -instance OpReturns SeqMem where - opReturns (Alloc _ space) = return [MemMem space] - opReturns (Inner ()) = pure [] - -instance PrettyLore SeqMem where - -instance TC.CheckableOp SeqMem where - checkOp (Alloc size _) = - TC.require [Prim int64] size - checkOp (Inner ()) = - pure () - -instance TC.Checkable SeqMem where - checkFParamLore = checkMemInfo - checkLParamLore = checkMemInfo - checkLetBoundLore = checkMemInfo - checkRetType = mapM_ TC.checkExtType . retTypeValues - primFParam name t = return $ Param name (MemPrim t) - matchPattern = matchPatternToExp - matchReturnType = matchFunctionReturnType - matchBranchType = matchBranchReturnType - -instance BinderOps SeqMem where - mkExpAttrB _ _ = return () - mkBodyB stms res = return $ Body () stms res - mkLetNamesB = mkLetNamesB' () - -instance BinderOps (Engine.Wise SeqMem) where - mkExpAttrB pat e = return $ Engine.mkWiseExpAttr pat () e - mkBodyB stms res = return $ Engine.mkWiseBody () stms res - mkLetNamesB = mkLetNamesB'' - -simplifyProg :: Prog SeqMem -> PassM (Prog SeqMem) -simplifyProg = - simplifyProgGeneric $ const $ return ((), mempty) - -simpleSeqMem :: Engine.SimpleOps SeqMem -simpleSeqMem = - simpleGeneric $ const $ return ((), mempty) diff --git a/src/Futhark/Test.hs b/src/Futhark/Test.hs --- a/src/Futhark/Test.hs +++ b/src/Futhark/Test.hs @@ -34,7 +34,6 @@ , ExpectedResult (..) , Success(..) , Values (..) - , GenValue (..) , Value ) where @@ -72,13 +71,13 @@ import Prelude import Futhark.Analysis.Metrics -import Futhark.Representation.Primitive +import Futhark.IR.Primitive (IntType(..), intValue, FloatType(..), intByteSize, floatByteSize) import Futhark.Test.Values import Futhark.Util (directoryContents, pmapIO) import Futhark.Util.Pretty (pretty, prettyText) import Language.Futhark.Syntax (PrimType(..), PrimValue(..)) -import Language.Futhark.Attributes (primValueType, primByteSize) +import Language.Futhark.Prop (primValueType, primByteSize) -- | Description of a test to be carried out on a Futhark program. -- The Futhark program is stored separately. @@ -632,6 +631,10 @@ binaryName :: FilePath -> FilePath binaryName = dropExtension +-- | @compileProgram extra_options futhark backend program@ compiles +-- @program@ with the command @futhark backend extra-options...@, and +-- returns stdout and stderr of the compiler. Throws an IO exception +-- containing stderr if compilation fails. compileProgram :: (MonadIO m, MonadError [T.Text] m) => [String] -> FilePath -> String -> FilePath -> m (SBS.ByteString, SBS.ByteString) @@ -646,6 +649,14 @@ options = [program, "-o", binOutputf] ++ extra_options progNotFound s = s <> ": command not found" +-- | @runProgram runner extra_options prog entry input@ runs the +-- Futhark program @prog@ (which must have the @.fut@ suffix), +-- executing the @entry@ entry point and providing @input@ on stdin. +-- The program must have been compiled in advance with +-- 'compileProgram'. If @runner@ is non-null, then it is used as +-- "interpreter" for the compiled program (e.g. @python@ when using +-- the Python backends, or @mono@ for the C# backends). The +-- @extra_options@ are passed to the program. runProgram :: MonadIO m => String -> [String] -> String -> T.Text -> Values diff --git a/src/Futhark/Test/Values.hs b/src/Futhark/Test/Values.hs --- a/src/Futhark/Test/Values.hs +++ b/src/Futhark/Test/Values.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Strict #-} -{-# LANGUAGE StrictData #-} +{-# LANGUAGE Trustworthy #-} -- | This module defines an efficient value representation as well as -- parsing and comparison functions. This is because the standard -- Futhark parser is not able to cope with large values (like arrays @@ -30,7 +30,6 @@ import Data.Binary import Data.Binary.Put import Data.Binary.Get -import Data.Binary.IEEE754 import qualified Data.ByteString.Lazy.Char8 as BS import Data.Int (Int8, Int16, Int32, Int64) import Data.Char (isSpace, ord, chr) @@ -38,17 +37,17 @@ import qualified Data.Vector.Unboxed.Mutable as UMVec import qualified Data.Vector.Unboxed as UVec import Data.Vector.Generic (freeze) -import Data.Loc (Pos(..)) import qualified Language.Futhark.Syntax as F import Language.Futhark.Pretty() -import Futhark.Representation.Primitive (PrimValue) +import Futhark.IR.Primitive (PrimValue) import Language.Futhark.Parser.Lexer import qualified Futhark.Util.Pretty as PP -import Futhark.Representation.AST.Attributes.Constants (IsValue(..)) -import Futhark.Representation.AST.Pretty () +import Futhark.IR.Prop.Constants (IsValue(..)) +import Futhark.IR.Pretty () import Futhark.Util.Pretty import Futhark.Util (maybeHead) +import Futhark.Util.Loc (Pos(..)) type STVector s = UMVec.STVector s @@ -56,8 +55,8 @@ type Vector = UVec.Vector -- | An efficiently represented Futhark value. Use 'pretty' to get a --- human-readable representation, and the instances of 'Get' and 'Put' --- to obtain binary representations +-- human-readable representation, and v'put' to obtain binary a +-- representation. data Value = Int8Value (Vector Int) (Vector Int8) | Int16Value (Vector Int) (Vector Int16) | Int32Value (Vector Int) (Vector Int32) @@ -86,8 +85,8 @@ put (Word16Value shape vs) = putBinaryValue " u16" shape vs putWord16le put (Word32Value shape vs) = putBinaryValue " u32" shape vs putWord32le put (Word64Value shape vs) = putBinaryValue " u64" shape vs putWord64le - put (Float32Value shape vs) = putBinaryValue " f32" shape vs putFloat32le - put (Float64Value shape vs) = putBinaryValue " f64" shape vs putFloat64le + put (Float32Value shape vs) = putBinaryValue " f32" shape vs putFloatle + put (Float64Value shape vs) = putBinaryValue " f64" shape vs putDoublele put (BoolValue shape vs) = putBinaryValue "bool" shape vs $ putInt8 . boolToInt where boolToInt True = 1 boolToInt False = 0 @@ -119,8 +118,8 @@ " u16" -> get' (Word16Value shape') getWord16le num_elems " u32" -> get' (Word32Value shape') getWord32le num_elems " u64" -> get' (Word64Value shape') getWord64le num_elems - " f32" -> get' (Float32Value shape') getFloat32le num_elems - " f64" -> get' (Float64Value shape') getFloat64le num_elems + " f32" -> get' (Float32Value shape') getFloatle num_elems + " f64" -> get' (Float64Value shape') getDoublele num_elems "bool" -> get' (BoolValue shape') getBool num_elems s -> fail $ "Cannot parse binary values of type " ++ show s where getBool = (/=0) <$> getWord8 @@ -159,9 +158,11 @@ pprArray [] vs = ppr $ F.primValue $ UVec.head vs pprArray (d:ds) vs = - brackets $ commasep $ map (pprArray ds . slice) [0..d-1] + brackets $ cat $ punctuate separator $ map (pprArray ds . slice) [0..d-1] where slice_size = product ds slice i = UVec.slice (i*slice_size) slice_size vs + separator | null ds = comma <> space + | otherwise = comma <> line -- | A representation of the simple values we represent in this module. data ValueType = ValueType [Int] F.PrimType diff --git a/src/Futhark/Tools.hs b/src/Futhark/Tools.hs --- a/src/Futhark/Tools.hs +++ b/src/Futhark/Tools.hs @@ -1,16 +1,16 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} +-- | An unstructured grab-bag of various tools and inspection +-- functions that didn't really fit anywhere else. module Futhark.Tools ( module Futhark.Construct - , nonuniqueParams , redomapToMapAndReduce , dissectScrema , sequentialStreamWholeArray , partitionChunkedFoldParameters - , partitionChunkedKernelFoldParameters -- * Primitive expressions , module Futhark.Analysis.PrimExp.Convert @@ -19,34 +19,22 @@ import Control.Monad.Identity -import Futhark.Representation.AST -import Futhark.Representation.SOACS.SOAC +import Futhark.IR +import Futhark.IR.SOACS.SOAC import Futhark.MonadFreshNames import Futhark.Construct import Futhark.Analysis.PrimExp.Convert import Futhark.Util -nonuniqueParams :: (MonadFreshNames m, Bindable lore, HasScope lore m, BinderOps lore) => - [LParam lore] -> m ([LParam lore], Stms lore) -nonuniqueParams params = runBinder $ forM params $ \param -> - if not $ primType $ paramType param then do - param_name <- newVName $ baseString (paramName param) ++ "_nonunique" - let param' = Param param_name $ paramType param - localScope (scopeOfLParams [param']) $ - letBindNames_ [paramName param] $ BasicOp $ Copy $ paramName param' - return param' - else - return param - -- | Turns a binding of a @redomap@ into two seperate bindings, a -- @map@ binding and a @reduce@ binding (returned in that order). -- -- Reuses the original pattern for the @reduce@, and creates a new -- pattern with new 'Ident's for the result of the @map@. -- --- Only handles a 'Pattern' with an empty 'patternContextElements' +-- Only handles a pattern with an empty 'patternContextElements'. redomapToMapAndReduce :: (MonadFreshNames m, Bindable lore, - ExpAttr lore ~ (), Op lore ~ SOAC lore) => + ExpDec lore ~ (), Op lore ~ SOAC lore) => Pattern lore -> ( SubExp , Commutativity @@ -65,10 +53,10 @@ redomapToMapAndReduce _ _ = error "redomapToMapAndReduce does not handle a non-empty 'patternContextElements'" -splitScanOrRedomap :: (Typed attr, MonadFreshNames m) => - [PatElemT attr] +splitScanOrRedomap :: (Typed dec, MonadFreshNames m) => + [PatElemT dec] -> SubExp -> LambdaT lore -> [SubExp] - -> m ([Ident], PatternT attr, [(SubExp, VName)]) + -> m ([Ident], PatternT dec, [(SubExp, VName)]) splitScanOrRedomap patelems w map_lam accs = do let (acc_patelems, arr_patelems) = splitAt (length accs) patelems (acc_ts, _arr_ts) = splitAt (length accs) $ lambdaReturnType map_lam @@ -101,14 +89,16 @@ -- the Scan. to_scan <- replicateM num_scans $ newVName "to_scan" to_red <- replicateM num_reds $ newVName "to_red" - letBindNames_ (to_scan <> to_red <> map_res) $ Op $ Screma w (mapSOAC map_lam) arrs + letBindNames (to_scan <> to_red <> map_res) $ Op $ Screma w (mapSOAC map_lam) arrs reduce <- reduceSOAC reds - letBindNames_ red_res $ Op $ Screma w reduce to_red + letBindNames red_res $ Op $ Screma w reduce to_red scan <- scanSOAC scans - letBindNames_ scan_res $ Op $ Screma w scan to_scan + letBindNames scan_res $ Op $ Screma w scan to_scan +-- | Turn a stream SOAC into statements that apply the stream lambda +-- to the entire input. sequentialStreamWholeArray :: (MonadBinder m, Bindable (Lore m)) => Pattern (Lore m) -> SubExp -> [SubExp] @@ -121,7 +111,7 @@ partitionChunkedFoldParameters (length nes) $ lambdaParams lam -- The chunk size is the full size of the array. - letBindNames_ [paramName chunk_size_param] $ BasicOp $ SubExp w + letBindNames [paramName chunk_size_param] $ BasicOp $ SubExp w -- The accumulator parameters are initialised to the neutral element. forM_ (zip fold_params nes) $ \(p, ne) -> @@ -143,21 +133,17 @@ case (arrayDims $ patElemType pe, se) of (dims, Var v) | not $ null dims -> - letBindNames_ [patElemName pe] $ BasicOp $ Reshape (map DimCoercion dims) v - _ -> letBindNames_ [patElemName pe] $ BasicOp $ SubExp se + letBindNames [patElemName pe] $ BasicOp $ Reshape (map DimCoercion dims) v + _ -> letBindNames [patElemName pe] $ BasicOp $ SubExp se -partitionChunkedFoldParameters :: Int -> [Param attr] - -> (Param attr, [Param attr], [Param attr]) +-- | Split the parameters of a stream reduction lambda into the chunk +-- size parameter, the accumulator parameters, and the input chunk +-- parameters. The integer argument is how many accumulators are +-- used. +partitionChunkedFoldParameters :: Int -> [Param dec] + -> (Param dec, [Param dec], [Param dec]) partitionChunkedFoldParameters _ [] = error "partitionChunkedFoldParameters: lambda takes no parameters" partitionChunkedFoldParameters num_accs (chunk_param : params) = let (acc_params, arr_params) = splitAt num_accs params in (chunk_param, acc_params, arr_params) - -partitionChunkedKernelFoldParameters :: Int -> [Param attr] - -> (VName, Param attr, [Param attr], [Param attr]) -partitionChunkedKernelFoldParameters num_accs (i_param : chunk_param : params) = - let (acc_params, arr_params) = splitAt num_accs params - in (paramName i_param, chunk_param, acc_params, arr_params) -partitionChunkedKernelFoldParameters _ _ = - error "partitionChunkedKernelFoldParameters: lambda takes too few parameters" diff --git a/src/Futhark/Transform/CopyPropagate.hs b/src/Futhark/Transform/CopyPropagate.hs --- a/src/Futhark/Transform/CopyPropagate.hs +++ b/src/Futhark/Transform/CopyPropagate.hs @@ -12,7 +12,7 @@ import Futhark.Pass import Futhark.MonadFreshNames -import Futhark.Representation.AST +import Futhark.IR import Futhark.Optimise.Simplify import qualified Futhark.Analysis.SymbolTable as ST import Futhark.Optimise.Simplify.Lore (Wise) diff --git a/src/Futhark/Transform/FirstOrderTransform.hs b/src/Futhark/Transform/FirstOrderTransform.hs --- a/src/Futhark/Transform/FirstOrderTransform.hs +++ b/src/Futhark/Transform/FirstOrderTransform.hs @@ -8,14 +8,13 @@ -- transformations in-place. module Futhark.Transform.FirstOrderTransform ( transformFunDef - , transformStms + , transformConsts , FirstOrderLore , Transformer , transformStmRecursively , transformLambda , transformSOAC - , transformBody ) where @@ -24,21 +23,23 @@ import qualified Data.Map.Strict as M import Data.List (zip4) -import qualified Futhark.Representation.AST as AST -import Futhark.Representation.SOACS +import qualified Futhark.IR as AST +import Futhark.IR.SOACS import Futhark.MonadFreshNames import Futhark.Tools -import Futhark.Representation.AST.Attributes.Aliases +import Futhark.IR.Prop.Aliases import Futhark.Util (chunks, splitAt3) -- | The constraints that must hold for a lore in order to be the -- target of first-order transformation. type FirstOrderLore lore = (Bindable lore, BinderOps lore, - LetAttr SOACS ~ LetAttr lore, - LParamAttr SOACS ~ LParamAttr lore, + LetDec SOACS ~ LetDec lore, + LParamInfo SOACS ~ LParamInfo lore, CanBeAliased (Op lore)) +-- | First-order-transform a single function, with the given scope +-- provided by top-level constants. transformFunDef :: (MonadFreshNames m, FirstOrderLore tolore) => Scope tolore -> FunDef SOACS -> m (AST.FunDef tolore) transformFunDef consts_scope (FunDef entry fname rettype params body) = do @@ -46,9 +47,10 @@ return $ FunDef entry fname rettype params body' where m = localScope (scopeOfFParams params) $ insertStmsM $ transformBody body -transformStms :: (MonadFreshNames m, FirstOrderLore tolore) => - Stms SOACS -> m (AST.Stms tolore) -transformStms stms = +-- | First-order-transform these top-level constants. +transformConsts :: (MonadFreshNames m, FirstOrderLore tolore) => + Stms SOACS -> m (AST.Stms tolore) +transformConsts stms = fmap snd $ modifyNameSource $ runState $ runBinderT m mempty where m = mapM_ transformStmRecursively stms @@ -56,18 +58,18 @@ -- first-order transformation. type Transformer m = (MonadBinder m, LocalScope (Lore m) m, Bindable (Lore m), BinderOps (Lore m), - LParamAttr SOACS ~ LParamAttr (Lore m), + LParamInfo SOACS ~ LParamInfo (Lore m), CanBeAliased (Op (Lore m))) -transformBody :: (Transformer m, LetAttr (Lore m) ~ LetAttr SOACS) => +transformBody :: (Transformer m, LetDec (Lore m) ~ LetDec SOACS) => Body -> m (AST.Body (Lore m)) transformBody (Body () bnds res) = insertStmsM $ do mapM_ transformStmRecursively bnds return $ resultBody res --- | First transform any nested 'Body' or 'Lambda' elements, then +-- | First transform any nested t'Body' or t'Lambda' elements, then -- apply 'transformSOAC' if the expression is a SOAC. -transformStmRecursively :: (Transformer m, LetAttr (Lore m) ~ LetAttr SOACS) => +transformStmRecursively :: (Transformer m, LetDec (Lore m) ~ LetDec SOACS) => Stm -> m () transformStmRecursively (Let pat aux (Op soac)) = @@ -77,7 +79,7 @@ transformStmRecursively (Let pat aux e) = certifying (stmAuxCerts aux) $ - letBind_ pat =<< mapExpM transform e + letBind pat =<< mapExpM transform e where transform = identityMapper { mapOnBody = \scope -> localScope scope . transformBody , mapOnRetType = return , mapOnBranchType = return @@ -132,7 +134,7 @@ forM_ (zip (lambdaParams map_lam) arrs) $ \(p, arr) -> do arr_t <- lookupType arr - letBindNames_ [paramName p] $ BasicOp $ Index arr $ + letBindNames [paramName p] $ BasicOp $ Index arr $ fullSlice arr_t [DimFix $ Var i] -- Insert the statements of the lambda. We have taken care to @@ -165,7 +167,7 @@ -- bound in the original pattern. names <- (++patternNames pat) <$> replicateM (length scanacc_params) (newVName "discard") - letBindNames_ names $ DoLoop [] merge loopform loop_body + letBindNames names $ DoLoop [] merge loopform loop_body transformSOAC pat (Stream w form lam arrs) = sequentialStreamWholeArray pat w nes lam arrs @@ -183,7 +185,7 @@ -- Scatter is in-place, so we use the input array as the output array. let merge = loopMerge asOuts $ map Var as_vs loopBody <- runBodyBinder $ - localScope (M.insert iter (IndexInfo Int32) $ + localScope (M.insert iter (IndexName Int32) $ scopeOfFParams $ map fst merge) $ do ivs' <- forM ivs $ \iv -> do iv_t <- lookupType iv @@ -199,7 +201,7 @@ foldM saveInArray arr $ zip indexes' values' return $ resultBody (map Var ress) - letBind_ pat $ DoLoop [] merge (ForLoop iter Int32 len []) loopBody + letBind pat $ DoLoop [] merge (ForLoop iter Int32 len []) loopBody transformSOAC pat (Hist len ops bucket_fun imgs) = do iter <- newVName "iter" @@ -211,7 +213,7 @@ -- Bind lambda-bodies for operators. loopBody <- runBodyBinder $ - localScope (M.insert iter (IndexInfo Int32) $ + localScope (M.insert iter (IndexName Int32) $ scopeOfFParams $ map fst merge) $ do -- Bind images to parameters of bucket function. @@ -256,14 +258,14 @@ return $ resultBody $ map Var $ concat hists_out'' -- Wrap up the above into a for-loop. - letBind_ pat $ DoLoop [] merge (ForLoop iter Int32 len []) loopBody + letBind pat $ DoLoop [] merge (ForLoop iter Int32 len []) loopBody -- | Recursively first-order-transform a lambda. transformLambda :: (MonadFreshNames m, Bindable lore, BinderOps lore, LocalScope somelore m, SameScope somelore lore, - LetAttr lore ~ LetAttr SOACS, + LetDec lore ~ LetDec SOACS, CanBeAliased (Op lore)) => Lambda -> m (AST.Lambda lore) transformLambda (Lambda params body rettype) = do diff --git a/src/Futhark/Transform/Rename.hs b/src/Futhark/Transform/Rename.hs --- a/src/Futhark/Transform/Rename.hs +++ b/src/Futhark/Transform/Rename.hs @@ -3,14 +3,9 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} --- | This module provides facilities for transforming Futhark programs such --- that names are unique, via the 'renameProg' function. --- Additionally, the module also supports adding integral \"tags\" to --- names (incarnated as the 'ID' type), in order to support more --- efficient comparisons and renamings. This is done by 'tagProg'. --- The intent is that you call 'tagProg' once at some early stage, --- then use 'renameProg' from then on. Functions are also provided --- for removing the tags again from expressions, patterns and typs. +{-# LANGUAGE Trustworthy #-} +-- | This module provides facilities for transforming Futhark programs +-- such that names are unique, via the 'renameProg' function. module Futhark.Transform.Rename ( -- * Renaming programs @@ -37,10 +32,10 @@ import qualified Data.Map.Strict as M import Data.Maybe -import Futhark.Representation.AST.Syntax -import Futhark.Representation.AST.Traversals -import Futhark.Representation.AST.Attributes.Names -import Futhark.Representation.AST.Attributes.Patterns +import Futhark.IR.Syntax +import Futhark.IR.Traversals +import Futhark.IR.Prop.Names +import Futhark.IR.Prop.Patterns import Futhark.FreshNames hiding (newName) import Futhark.MonadFreshNames (MonadFreshNames(..), modifyNameSource, newName) import Futhark.Transform.Substitute @@ -95,8 +90,8 @@ -- | Produce an equivalent pattern but with each pattern element given -- a new name. -renamePattern :: (Rename attr, MonadFreshNames m) => - PatternT attr -> m (PatternT attr) +renamePattern :: (Rename dec, MonadFreshNames m) => + PatternT dec -> m (PatternT dec) renamePattern = modifyNameSource . runRenamer . rename' where rename' pat = bind (patternNames pat) $ rename pat @@ -128,8 +123,7 @@ rename :: a -> RenameM a instance Rename VName where - rename name = fromMaybe name <$> - asks (M.lookup name . envNameMap) + rename name = asks (fromMaybe name . M.lookup name . envNameMap) instance Rename a => Rename [a] where rename = mapM rename @@ -187,27 +181,30 @@ rename (Var v) = Var <$> rename v rename (Constant v) = return $ Constant v -instance Rename attr => Rename (Param attr) where - rename (Param name attr) = Param <$> rename name <*> rename attr +instance Rename dec => Rename (Param dec) where + rename (Param name dec) = Param <$> rename name <*> rename dec -instance Rename attr => Rename (PatternT attr) where +instance Rename dec => Rename (PatternT dec) where rename (Pattern context values) = Pattern <$> rename context <*> rename values -instance Rename attr => Rename (PatElemT attr) where - rename (PatElem ident attr) = PatElem <$> rename ident <*> rename attr +instance Rename dec => Rename (PatElemT dec) where + rename (PatElem ident dec) = PatElem <$> rename ident <*> rename dec instance Rename Certificates where rename (Certificates cs) = Certificates <$> rename cs -instance Rename attr => Rename (StmAux attr) where - rename (StmAux cs attr) = - StmAux <$> rename cs <*> rename attr +instance Rename Attrs where + rename = pure +instance Rename dec => Rename (StmAux dec) where + rename (StmAux cs attrs dec) = + StmAux <$> rename cs <*> rename attrs <*> rename dec + instance Renameable lore => Rename (Body lore) where - rename (Body attr stms res) = do - attr' <- rename attr + rename (Body dec stms res) = do + dec' <- rename dec renamingStms stms $ \stms' -> - Body attr' stms' <$> rename res + Body dec' stms' <$> rename res instance Renameable lore => Rename (Stm lore) where rename (Let pat elore e) = Let <$> rename pat <*> rename elore <*> rename e @@ -293,11 +290,11 @@ rename (DimSlice i n s) = DimSlice <$> rename i <*> rename n <*> rename s -- | Lores in which all annotations are renameable. -type Renameable lore = (Rename (LetAttr lore), - Rename (ExpAttr lore), - Rename (BodyAttr lore), - Rename (FParamAttr lore), - Rename (LParamAttr lore), +type Renameable lore = (Rename (LetDec lore), + Rename (ExpDec lore), + Rename (BodyDec lore), + Rename (FParamInfo lore), + Rename (LParamInfo lore), Rename (RetType lore), Rename (BranchType lore), Rename (Op lore)) diff --git a/src/Futhark/Transform/Substitute.hs b/src/Futhark/Transform/Substitute.hs --- a/src/Futhark/Transform/Substitute.hs +++ b/src/Futhark/Transform/Substitute.hs @@ -2,6 +2,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE Safe #-} -- | -- -- This module contains facilities for replacing variable names in @@ -15,11 +16,11 @@ import Control.Monad.Identity import qualified Data.Map.Strict as M -import Futhark.Representation.AST.Syntax -import Futhark.Representation.AST.Traversals -import Futhark.Representation.AST.Attributes.Scope +import Futhark.IR.Syntax +import Futhark.IR.Traversals +import Futhark.IR.Prop.Scope import Futhark.Analysis.PrimExp -import Futhark.Representation.AST.Attributes.Names +import Futhark.IR.Prop.Names -- | The substitutions to be made are given by a mapping from names to -- names. @@ -72,21 +73,27 @@ instance Substitutable lore => Substitute (Exp lore) where substituteNames substs = mapExp $ replace substs -instance Substitute attr => Substitute (PatElemT attr) where - substituteNames substs (PatElem ident attr) = - PatElem (substituteNames substs ident) (substituteNames substs attr) +instance Substitute dec => Substitute (PatElemT dec) where + substituteNames substs (PatElem ident dec) = + PatElem (substituteNames substs ident) (substituteNames substs dec) -instance Substitute attr => Substitute (StmAux attr) where - substituteNames substs (StmAux cs attr) = - StmAux (substituteNames substs cs) (substituteNames substs attr) +instance Substitute Attrs where + substituteNames _ attrs = attrs -instance Substitute attr => Substitute (Param attr) where - substituteNames substs (Param name attr) = +instance Substitute dec => Substitute (StmAux dec) where + substituteNames substs (StmAux cs attrs dec) = + StmAux + (substituteNames substs cs) + (substituteNames substs attrs) + (substituteNames substs dec) + +instance Substitute dec => Substitute (Param dec) where + substituteNames substs (Param name dec) = Param (substituteNames substs name) - (substituteNames substs attr) + (substituteNames substs dec) -instance Substitute attr => Substitute (PatternT attr) where +instance Substitute dec => Substitute (PatternT dec) where substituteNames substs (Pattern context values) = Pattern (substituteNames substs context) (substituteNames substs values) @@ -102,9 +109,9 @@ (substituteNames substs e) instance Substitutable lore => Substitute (Body lore) where - substituteNames substs (Body attr stms res) = + substituteNames substs (Body dec stms res) = Body - (substituteNames substs attr) + (substituteNames substs dec) (substituteNames substs stms) (substituteNames substs res) @@ -167,26 +174,26 @@ substituteNames substs = fmap $ substituteNames substs instance Substitutable lore => Substitute (NameInfo lore) where - substituteNames subst (LetInfo attr) = - LetInfo $ substituteNames subst attr - substituteNames subst (FParamInfo attr) = - FParamInfo $ substituteNames subst attr - substituteNames subst (LParamInfo attr) = - LParamInfo $ substituteNames subst attr - substituteNames _ (IndexInfo it) = - IndexInfo it + substituteNames subst (LetName dec) = + LetName $ substituteNames subst dec + substituteNames subst (FParamName dec) = + FParamName $ substituteNames subst dec + substituteNames subst (LParamName dec) = + LParamName $ substituteNames subst dec + substituteNames _ (IndexName it) = + IndexName it instance Substitute FV where substituteNames subst = fvNames . substituteNames subst . freeIn -- | Lores in which all annotations support name -- substitution. -type Substitutable lore = (Annotations lore, - Substitute (ExpAttr lore), - Substitute (BodyAttr lore), - Substitute (LetAttr lore), - Substitute (FParamAttr lore), - Substitute (LParamAttr lore), +type Substitutable lore = (Decorations lore, + Substitute (ExpDec lore), + Substitute (BodyDec lore), + Substitute (LetDec lore), + Substitute (FParamInfo lore), + Substitute (LParamInfo lore), Substitute (RetType lore), Substitute (BranchType lore), Substitute (Op lore)) diff --git a/src/Futhark/TypeCheck.hs b/src/Futhark/TypeCheck.hs --- a/src/Futhark/TypeCheck.hs +++ b/src/Futhark/TypeCheck.hs @@ -2,7 +2,7 @@ {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE Strict #-} -{-# LANGUAGE StrictData #-} +{-# LANGUAGE Trustworthy #-} -- | The type checker checks whether the program is type-consistent. module Futhark.TypeCheck ( -- * Interface @@ -19,8 +19,6 @@ , CheckableOp (..) , lookupVar , lookupAliases - , Occurences - , collectOccurences , checkOpWith -- * Checkers @@ -60,7 +58,7 @@ import Futhark.Analysis.PrimExp import Futhark.Construct (instantiateShapes) -import Futhark.Representation.Aliases +import Futhark.IR.Aliases import Futhark.Util import Futhark.Util.Pretty (Pretty, prettyDoc, indent, ppr, text, (<+>), align) @@ -254,7 +252,7 @@ HasScope (Aliases lore) (TypeM lore) where lookupType = fmap typeOf . lookupVar askScope = asks $ M.fromList . mapMaybe varType . M.toList . envVtable - where varType (name, attr) = Just (name, attr) + where varType (name, dec) = Just (name, dec) runTypeM :: Env lore -> TypeM lore a -> Either (TypeError lore) (a, Consumption) @@ -295,9 +293,9 @@ observe :: Checkable lore => VName -> TypeM lore () observe name = do - attr <- lookupVar name - unless (primType $ typeOf attr) $ - occur [observation $ oneName name <> aliases attr] + dec <- lookupVar name + unless (primType $ typeOf dec) $ + occur [observation $ oneName name <> aliases dec] -- | Proclaim that we have written to the given variables. consume :: Checkable lore => Names -> TypeM lore () @@ -356,7 +354,7 @@ expandAliases names env = names <> aliasesOfAliases where aliasesOfAliases = mconcat . map look . namesToList $ names look k = case M.lookup k $ envVtable env of - Just (LetInfo (als, _)) -> unNames als + Just (LetName (als, _)) -> unNames als _ -> mempty binding :: Checkable lore => @@ -367,14 +365,14 @@ where bindVars = M.foldlWithKey' bindVar boundnames = M.keys bnds - bindVar env name (LetInfo (Names' als, attr)) = - let als' | primType (typeOf attr) = mempty + bindVar env name (LetName (Names' als, dec)) = + let als' | primType (typeOf dec) = mempty | otherwise = expandAliases als env in env { envVtable = - M.insert name (LetInfo (Names' als', attr)) $ envVtable env + M.insert name (LetName (Names' als', dec)) $ envVtable env } - bindVar env name attr = - env { envVtable = M.insert name attr $ envVtable env } + bindVar env name dec = + env { envVtable = M.insert name dec $ envVtable env } -- Check whether the bound variables have been used correctly -- within their scope. @@ -389,7 +387,7 @@ bnd <- asks $ M.lookup name . envVtable case bnd of Nothing -> bad $ UnknownVariableError name - Just attr -> return attr + Just dec -> return dec lookupAliases :: Checkable lore => VName -> TypeM lore Names lookupAliases name = do @@ -399,7 +397,7 @@ else oneName name <> aliases info aliases :: NameInfo (Aliases lore) -> Names -aliases (LetInfo (als, _)) = unNames als +aliases (LetName (als, _)) = unNames als aliases _ = mempty subExpAliasesM :: Checkable lore => SubExp -> TypeM lore Names @@ -491,7 +489,7 @@ checkFun (FunDef _ fname rettype params body) = context ("In function " ++ nameToString fname) $ checkFun' (fname, - retTypeValues rettype, + map declExtTypeOf rettype, funParamsToNameInfos params) consumable $ do checkFunParams params checkRetType rettype @@ -505,7 +503,7 @@ -> [(VName, NameInfo (Aliases lore))] funParamsToNameInfos = map nameTypeAndLore where nameTypeAndLore fparam = (paramName fparam, - FParamInfo $ paramAttr fparam) + FParamName $ paramDec fparam) checkFunParams :: Checkable lore => [FParam lore] -> TypeM lore () @@ -513,7 +511,7 @@ where param_bound = namesFromList $ map paramName params check prev param = context ("In function parameter " ++ pretty param) $ do - checkFParamLore (paramName param) (paramAttr param) + checkFParamLore (paramName param) (paramDec param) case namesToList $ (freeIn param `namesIntersection` param_bound) `namesSubtract` prev of @@ -526,7 +524,7 @@ [LParam lore] -> TypeM lore () checkLambdaParams = mapM_ $ \param -> context ("In lambda parameter " ++ pretty param) $ - checkLParamLore (paramName param) (paramAttr param) + checkLParamLore (paramName param) (paramDec param) checkFun' :: Checkable lore => (Name, @@ -789,6 +787,14 @@ (mergepat, mergeexps) = unzip merge mergeargs <- mapM checkArg mergeexps + let val_free = freeIn $ map fst valmerge + usedInVal p = paramName p `nameIn` val_free + case find (not . usedInVal . fst) ctxmerge of + Just p -> + bad $ TypeError $ "Loop context parameter " ++ pretty p ++ " unused." + Nothing -> + return () + binding (scopeOf form) $ do case form of ForLoop loopvar it boundexp loopvars -> do @@ -801,8 +807,8 @@ observe a case peelArray 1 a_t of Just a_t_r -> do - checkLParamLore (paramName p) $ paramAttr p - unless (a_t_r `subtypeOf` typeOf (paramAttr p)) $ + checkLParamLore (paramName p) $ paramDec p + unless (a_t_r `subtypeOf` typeOf (paramDec p)) $ bad $ TypeError $ "Loop parameter " ++ pretty p ++ " not valid for element of " ++ pretty a ++ ", which has row type " ++ pretty a_t_r _ -> bad $ TypeError $ "Cannot loop over " ++ pretty a ++ @@ -820,7 +826,7 @@ pretty (paramType condparam) ++ "." Nothing -> bad $ TypeError $ - "Conditional '" ++ pretty cond ++ "' of while-loop is not a merge varible." + "Conditional '" ++ pretty cond ++ "' of while-loop is not a merge variable." let funparams = mergepat paramts = map paramDeclType funparams checkFuncall Nothing paramts mergeargs @@ -910,9 +916,9 @@ require [Prim t] e2 checkPatElem :: Checkable lore => - PatElemT (LetAttr lore) -> TypeM lore () -checkPatElem (PatElem name attr) = context ("When checking pattern element " ++ pretty name) $ - checkLetBoundLore name attr + PatElemT (LetDec lore) -> TypeM lore () +checkPatElem (PatElem name dec) = context ("When checking pattern element " ++ pretty name) $ + checkLetBoundLore name dec checkDimIndex :: Checkable lore => DimIndex SubExp -> TypeM lore () @@ -923,9 +929,9 @@ Stm (Aliases lore) -> TypeM lore a -> TypeM lore a -checkStm stm@(Let pat (StmAux (Certificates cs) (_,attr)) e) m = do +checkStm stm@(Let pat (StmAux (Certificates cs) _ (_,dec)) e) m = do context "When checking certificates" $ mapM_ (requireI [Prim Cert]) cs - context "When checking expression annotation" $ checkExpLore attr + context "When checking expression annotation" $ checkExpLore dec context ("When matching\n" ++ message " " pat ++ "\nwith\n" ++ message " " e) $ matchPattern pat e binding (maybeWithoutAliases $ scopeOf stm) $ do @@ -943,7 +949,7 @@ case stmExp stm of Apply{} -> M.map withoutAliases _ -> id - withoutAliases (LetInfo (_, lattr)) = LetInfo (mempty, lattr) + withoutAliases (LetName (_, ldec)) = LetName (mempty, ldec) withoutAliases info = info matchExtPattern :: Checkable lore => @@ -1049,7 +1055,7 @@ checkFun' (fname, staticShapes $ map (`toDecl` Nonunique) rettype, [ (paramName param, - LParamInfo $ paramAttr param) + LParamName $ paramDec param) | param <- params ]) consumable $ do checkLambdaParams params mapM_ checkType rettype @@ -1082,45 +1088,45 @@ unless (primExpType e == t) $ bad $ TypeError $ pretty e ++ " must have type " ++ pretty t -class Attributes lore => CheckableOp lore where +class ASTLore lore => CheckableOp lore where checkOp :: OpWithAliases (Op lore) -> TypeM lore () -- ^ Used at top level; can be locally changed with 'checkOpWith'. -- | The class of lores that can be type-checked. -class (Attributes lore, CanBeAliased (Op lore), CheckableOp lore) => Checkable lore where - checkExpLore :: ExpAttr lore -> TypeM lore () - checkBodyLore :: BodyAttr lore -> TypeM lore () - checkFParamLore :: VName -> FParamAttr lore -> TypeM lore () - checkLParamLore :: VName -> LParamAttr lore -> TypeM lore () - checkLetBoundLore :: VName -> LetAttr lore -> TypeM lore () +class (ASTLore lore, CanBeAliased (Op lore), CheckableOp lore) => Checkable lore where + checkExpLore :: ExpDec lore -> TypeM lore () + checkBodyLore :: BodyDec lore -> TypeM lore () + checkFParamLore :: VName -> FParamInfo lore -> TypeM lore () + checkLParamLore :: VName -> LParamInfo lore -> TypeM lore () + checkLetBoundLore :: VName -> LetDec lore -> TypeM lore () checkRetType :: [RetType lore] -> TypeM lore () matchPattern :: Pattern (Aliases lore) -> Exp (Aliases lore) -> TypeM lore () primFParam :: VName -> PrimType -> TypeM lore (FParam (Aliases lore)) matchReturnType :: [RetType lore] -> Result -> TypeM lore () matchBranchType :: [BranchType lore] -> Body (Aliases lore) -> TypeM lore () - default checkExpLore :: ExpAttr lore ~ () => ExpAttr lore -> TypeM lore () + default checkExpLore :: ExpDec lore ~ () => ExpDec lore -> TypeM lore () checkExpLore = return - default checkBodyLore :: BodyAttr lore ~ () => BodyAttr lore -> TypeM lore () + default checkBodyLore :: BodyDec lore ~ () => BodyDec lore -> TypeM lore () checkBodyLore = return - default checkFParamLore :: FParamAttr lore ~ DeclType => VName -> FParamAttr lore -> TypeM lore () + default checkFParamLore :: FParamInfo lore ~ DeclType => VName -> FParamInfo lore -> TypeM lore () checkFParamLore _ = checkType - default checkLParamLore :: LParamAttr lore ~ Type => VName -> LParamAttr lore -> TypeM lore () + default checkLParamLore :: LParamInfo lore ~ Type => VName -> LParamInfo lore -> TypeM lore () checkLParamLore _ = checkType - default checkLetBoundLore :: LetAttr lore ~ Type => VName -> LetAttr lore -> TypeM lore () + default checkLetBoundLore :: LetDec lore ~ Type => VName -> LetDec lore -> TypeM lore () checkLetBoundLore _ = checkType default checkRetType :: RetType lore ~ DeclExtType => [RetType lore] -> TypeM lore () - checkRetType = mapM_ checkExtType . retTypeValues + checkRetType = mapM_ $ checkExtType . declExtTypeOf default matchPattern :: Pattern (Aliases lore) -> Exp (Aliases lore) -> TypeM lore () matchPattern pat = matchExtPattern pat <=< expExtType - default primFParam :: FParamAttr lore ~ DeclType => VName -> PrimType -> TypeM lore (FParam (Aliases lore)) + default primFParam :: FParamInfo lore ~ DeclType => VName -> PrimType -> TypeM lore (FParam (Aliases lore)) primFParam name t = return $ Param name (Prim t) default matchReturnType :: RetType lore ~ DeclExtType => [RetType lore] -> Result -> TypeM lore () diff --git a/src/Futhark/Util.hs b/src/Futhark/Util.hs --- a/src/Futhark/Util.hs +++ b/src/Futhark/Util.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE Trustworthy #-} -- | Non-Futhark-specific utilities. If you find yourself writing -- general functions on generic data structures, consider putting them -- here. @@ -133,8 +134,8 @@ unixEnvironment :: [(String,String)] unixEnvironment = unsafePerformIO getEnvironment --- Is an environment variable set to 0 or 1? If 0, return False; if 1, True; --- otherwise the default value. +-- | Is an environment variable set to 0 or 1? If 0, return False; if +-- 1, True; otherwise the default value. isEnvVarSet :: String -> Bool -> Bool isEnvVarSet name default_val = fromMaybe default_val $ do val <- lookup name unixEnvironment @@ -262,10 +263,15 @@ -- -- (c) The University of Glasgow, 1997-2006 +-- | As the user typed it. +type UserString = String -type UserString = String -- As the user typed it -type EncodedString = String -- Encoded form +-- | Encoded form. +type EncodedString = String +-- | Z-encode a string using a slightly simplified variant of GHC +-- Z-encoding. The encoded string is a valid identifier in most +-- programming languages. zEncodeString :: UserString -> EncodedString zEncodeString "" = "" zEncodeString (c:cs) = encodeDigitChar c ++ concatMap encodeChar cs diff --git a/src/Futhark/Util/Loc.hs b/src/Futhark/Util/Loc.hs new file mode 100644 --- /dev/null +++ b/src/Futhark/Util/Loc.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE Trustworthy #-} +-- | A Safe Haskell-trusted re-export of the @srcloc@ package. +module Futhark.Util.Loc ( module Data.Loc ) where + +import Data.Loc diff --git a/src/Futhark/Util/Log.hs b/src/Futhark/Util/Log.hs --- a/src/Futhark/Util/Log.hs +++ b/src/Futhark/Util/Log.hs @@ -18,6 +18,7 @@ import qualified Data.Text as T import qualified Data.DList as DL +-- | An efficiently catenable sequence of log entries. newtype Log = Log { unLog :: DL.DList T.Text } instance Semigroup Log where diff --git a/src/Futhark/Util/Pretty.hs b/src/Futhark/Util/Pretty.hs --- a/src/Futhark/Util/Pretty.hs +++ b/src/Futhark/Util/Pretty.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE Trustworthy #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | A re-export of the prettyprinting library, along with some convenience functions. module Futhark.Util.Pretty diff --git a/src/Futhark/Version.hs b/src/Futhark/Version.hs --- a/src/Futhark/Version.hs +++ b/src/Futhark/Version.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE Trustworthy #-} -- | This module exports version information about the Futhark -- compiler. module Futhark.Version diff --git a/src/Language/Futhark.hs b/src/Language/Futhark.hs --- a/src/Language/Futhark.hs +++ b/src/Language/Futhark.hs @@ -1,7 +1,8 @@ +{-# LANGUAGE Safe #-} -- | Re-export the external Futhark modules for convenience. module Language.Futhark ( module Language.Futhark.Syntax - , module Language.Futhark.Attributes + , module Language.Futhark.Prop , module Language.Futhark.Pretty , Ident, DimIndex, Exp, Pattern @@ -14,7 +15,7 @@ where import Language.Futhark.Syntax -import Language.Futhark.Attributes +import Language.Futhark.Prop import Language.Futhark.Pretty -- | An identifier with type- and aliasing information. diff --git a/src/Language/Futhark/Attributes.hs b/src/Language/Futhark/Attributes.hs deleted file mode 100644 --- a/src/Language/Futhark/Attributes.hs +++ /dev/null @@ -1,1048 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} --- | This module provides various simple ways to query and manipulate --- fundamental Futhark terms, such as types and values. The intent is to --- keep "Futhark.Language.Syntax" simple, and put whatever embellishments --- we need here. -module Language.Futhark.Attributes - ( - -- * Various - Intrinsic(..) - , intrinsics - , maxIntrinsicTag - , namesToPrimTypes - , qualName - , qualify - , typeName - , valueType - , primValueType - , leadingOperator - , progImports - , decImports - , progModuleTypes - , identifierReference - , prettyStacktrace - - -- * Queries on expressions - , typeOf - - -- * Queries on patterns and params - , patternIdents - , patternNames - , patternMap - , patternType - , patternStructType - , patternParam - , patternOrderZero - , patternDimNames - - -- * Queries on types - , uniqueness - , unique - , aliases - , diet - , arrayRank - , arrayShape - , nestedDims - , orderZero - , unfoldFunType - , foldFunType - , typeVars - , typeDimNames - , primByteSize - - -- * Operations on types - , rank - , peelArray - , stripArray - , arrayOf - , toStructural - , toStruct - , fromStruct - , setAliases - , addAliases - , setUniqueness - , noSizes - , addSizes - , anySizes - , traverseDims - , DimPos(..) - , mustBeExplicit - , mustBeExplicitInType - , tupleRecord - , isTupleRecord - , areTupleFields - , tupleFields - , tupleFieldNames - , sortFields - , sortConstrs - , isTypeParam - , isSizeParam - , combineTypeShapes - , matchDims - , unscopeType - , onRecordField - - -- | Values of these types are produces by the parser. They use - -- unadorned names and have no type information, apart from that - -- which is syntactically required. - , NoInfo(..) - , UncheckedType - , UncheckedTypeExp - , UncheckedIdent - , UncheckedTypeDecl - , UncheckedDimIndex - , UncheckedExp - , UncheckedModExp - , UncheckedSigExp - , UncheckedTypeParam - , UncheckedPattern - , UncheckedValBind - , UncheckedDec - , UncheckedProg - , UncheckedCase - ) - where - -import Control.Monad.State -import Control.Monad.Writer hiding (Sum) -import Data.Char -import Data.Foldable -import qualified Data.Map.Strict as M -import qualified Data.Set as S -import Data.List (sortOn, genericLength, isPrefixOf, nub) -import Data.Loc -import Data.Maybe -import Data.Ord -import Data.Bifunctor -import Data.Bifoldable -import Data.Bitraversable (bitraverse) - -import Prelude - -import Futhark.Util.Pretty - -import Language.Futhark.Syntax -import qualified Futhark.Representation.Primitive as Primitive - --- | Return the dimensionality of a type. For non-arrays, this is --- zero. For a one-dimensional array it is one, for a two-dimensional --- it is two, and so forth. -arrayRank :: TypeBase dim as -> Int -arrayRank = shapeRank . arrayShape - --- | Return the shape of a type - for non-arrays, this is 'mempty'. -arrayShape :: TypeBase dim as -> ShapeDecl dim -arrayShape (Array _ _ _ ds) = ds -arrayShape _ = mempty - --- | Return any shape declarations in the type, with duplicates --- removed. -nestedDims :: TypeBase (DimDecl VName) as -> [DimDecl VName] -nestedDims t = - case t of Array _ _ a ds -> - nub $ nestedDims (Scalar a) <> shapeDims ds - Scalar (Record fs) -> - nub $ foldMap nestedDims fs - Scalar Prim{} -> - mempty - Scalar (Sum cs) -> - nub $ foldMap (foldMap nestedDims) cs - Scalar (Arrow _ v t1 t2) -> - filter (notV v) $ nestedDims t1 <> nestedDims t2 - Scalar (TypeVar _ _ _ targs) -> - concatMap typeArgDims targs - - where typeArgDims (TypeArgDim d _) = [d] - typeArgDims (TypeArgType at _) = nestedDims at - - notV Unnamed = const True - notV (Named v) = (/=NamedDim (qualName v)) - --- | Change the shape of a type to be just the 'Rank'. -noSizes :: TypeBase (DimDecl vn) as -> TypeBase () as -noSizes = first $ const () - --- | Add size annotations that are all 'AnyDim'. -addSizes :: TypeBase () as -> TypeBase (DimDecl vn) as -addSizes = first $ const AnyDim - --- | Change all size annotations to be 'AnyDim'. -anySizes :: TypeBase (DimDecl vn) as -> TypeBase (DimDecl vn) as -anySizes = first $ const AnyDim - --- | Where does this dimension occur? -data DimPos - = PosImmediate - -- ^ Immediately in the argument to 'traverseDims'. - | PosParam - -- ^ In a function parameter type. - | PosReturn - -- ^ In a function return type. - deriving (Eq, Ord, Show) - --- | Perform a traversal (possibly including replacement) on sizes --- that are parameters in a function type, but also including the type --- immediately passed to the function. -traverseDims :: forall f fdim tdim als. - Applicative f => - (DimPos -> fdim -> f tdim) - -> TypeBase fdim als - -> f (TypeBase tdim als) -traverseDims f = go PosImmediate - where go :: forall als'. DimPos -> TypeBase fdim als' -> f (TypeBase tdim als') - go b t@Array{} = bitraverse (f b) pure t - go b (Scalar (Record fields)) = Scalar . Record <$> traverse (go b) fields - go b (Scalar (TypeVar as u tn targs)) = - Scalar <$> (TypeVar as u tn <$> traverse (onTypeArg b) targs) - go b (Scalar (Sum cs)) = Scalar . Sum <$> traverse (traverse (go b)) cs - go _ (Scalar (Prim t)) = pure $ Scalar $ Prim t - go _ (Scalar (Arrow als p t1 t2)) = - Scalar <$> (Arrow als p <$> go PosParam t1 <*> go PosReturn t2) - - onTypeArg b (TypeArgDim d loc) = - TypeArgDim <$> f b d <*> pure loc - onTypeArg b (TypeArgType t loc) = - TypeArgType <$> go b t <*> pure loc - -mustBeExplicitAux :: StructType -> M.Map VName Bool -mustBeExplicitAux t = - execState (traverseDims onDim t) mempty - where onDim PosImmediate (NamedDim d) = - modify $ \s -> M.insertWith (&&) (qualLeaf d) False s - onDim _ (NamedDim d) = - modify $ M.insertWith (&&) (qualLeaf d) True - onDim _ _ = - return () - --- | Figure out which of the sizes in a parameter type must be passed --- explicitly, because their first use is as something else than just --- an array dimension. 'mustBeExplicit' is like this function, but --- first decomposes into parameter types. -mustBeExplicitInType :: StructType -> S.Set VName -mustBeExplicitInType t = - S.fromList $ M.keys $ M.filter id $ mustBeExplicitAux t - --- | Figure out which of the sizes in a binding type must be passed --- explicitly, because their first use is as something else than just --- an array dimension. -mustBeExplicit :: StructType -> S.Set VName -mustBeExplicit bind_t = - let (ts, ret) = unfoldFunType bind_t - alsoRet = M.unionWith (&&) $ - M.fromList $ zip (S.toList $ typeDimNames ret) $ repeat True - in S.fromList $ M.keys $ M.filter id $ alsoRet $ foldl' onType mempty ts - where onType uses t = uses <> mustBeExplicitAux t -- Left-biased union. - --- | Return the uniqueness of a type. -uniqueness :: TypeBase shape as -> Uniqueness -uniqueness (Array _ u _ _) = u -uniqueness (Scalar (TypeVar _ u _ _)) = u -uniqueness (Scalar (Sum ts)) = foldMap (foldMap uniqueness) $ M.elems ts -uniqueness (Scalar (Record fs)) = foldMap uniqueness $ M.elems fs -uniqueness _ = Nonunique - --- | @unique t@ is 'True' if the type of the argument is unique. -unique :: TypeBase shape as -> Bool -unique = (==Unique) . uniqueness - --- | Return the set of all variables mentioned in the aliasing of a --- type. -aliases :: Monoid as => TypeBase shape as -> as -aliases = bifoldMap (const mempty) id - --- | @diet t@ returns a description of how a function parameter of --- type @t@ might consume its argument. -diet :: TypeBase shape as -> Diet -diet (Scalar (Record ets)) = RecordDiet $ fmap diet ets -diet (Scalar (Prim _)) = Observe -diet (Scalar (Arrow _ _ t1 t2)) = FuncDiet (diet t1) (diet t2) -diet (Array _ Unique _ _) = Consume -diet (Array _ Nonunique _ _) = Observe -diet (Scalar (TypeVar _ Unique _ _)) = Consume -diet (Scalar (TypeVar _ Nonunique _ _)) = Observe -diet (Scalar Sum{}) = Observe - --- | Convert any type to one that has rank information, no alias --- information, and no embedded names. -toStructural :: TypeBase dim as - -> TypeBase () () -toStructural = flip setAliases () . first (const ()) - --- | Remove aliasing information from a type. -toStruct :: TypeBase dim as - -> TypeBase dim () -toStruct t = t `setAliases` () - --- | Replace no aliasing with an empty alias set. -fromStruct :: TypeBase dim as - -> TypeBase dim Aliasing -fromStruct t = t `setAliases` S.empty - --- | @peelArray n t@ returns the type resulting from peeling the first --- @n@ array dimensions from @t@. Returns @Nothing@ if @t@ has less --- than @n@ dimensions. -peelArray :: Int -> TypeBase dim as -> Maybe (TypeBase dim as) -peelArray n (Array als u t shape) - | shapeRank shape == n = - Just $ Scalar t `addAliases` const als - | otherwise = - Array als u t <$> stripDims n shape -peelArray _ _ = Nothing - --- | @arrayOf t s u@ constructs an array type. The convenience --- compared to using the 'Array' constructor directly is that @t@ can --- itself be an array. If @t@ is an @n@-dimensional array, and @s@ is --- a list of length @n@, the resulting type is of an @n+m@ dimensions. --- The uniqueness of the new array will be @u@, no matter the --- uniqueness of @t@. -arrayOf :: Monoid as => - TypeBase dim as - -> ShapeDecl dim - -> Uniqueness - -> TypeBase dim as -arrayOf t = arrayOfWithAliases (t `setUniqueness` Nonunique) mempty - -arrayOfWithAliases :: Monoid as => - TypeBase dim as - -> as - -> ShapeDecl dim - -> Uniqueness - -> TypeBase dim as -arrayOfWithAliases (Array as1 _ et shape1) as2 shape2 u = - Array (as1<>as2) u et (shape2 <> shape1) -arrayOfWithAliases (Scalar t) as shape u = - Array as u (second (const ()) t) shape - --- | @stripArray n t@ removes the @n@ outermost layers of the array. --- Essentially, it is the type of indexing an array of type @t@ with --- @n@ indexes. -stripArray :: Int -> TypeBase dim as -> TypeBase dim as -stripArray n (Array als u et shape) - | Just shape' <- stripDims n shape = - Array als u et shape' - | otherwise = - Scalar et `setUniqueness` u `setAliases` als -stripArray _ t = t - --- | Create a record type corresponding to a tuple with the given --- element types. -tupleRecord :: [TypeBase dim as] -> TypeBase dim as -tupleRecord = Scalar . Record . M.fromList . zip tupleFieldNames - -isTupleRecord :: TypeBase dim as -> Maybe [TypeBase dim as] -isTupleRecord (Scalar (Record fs)) = areTupleFields fs -isTupleRecord _ = Nothing - --- | Does this record map correspond to a tuple? -areTupleFields :: M.Map Name a -> Maybe [a] -areTupleFields fs = - let fs' = sortFields fs - in if and $ zipWith (==) (map fst fs') tupleFieldNames - then Just $ map snd fs' - else Nothing - --- | Construct a record map corresponding to a tuple. -tupleFields :: [a] -> M.Map Name a -tupleFields as = M.fromList $ zip tupleFieldNames as - --- | Increasing field names for a tuple (starts at 0). -tupleFieldNames :: [Name] -tupleFieldNames = map (nameFromString . show) [(0::Int)..] - --- | Sort fields by their name; taking care to sort numeric fields by --- their numeric value. This ensures that tuples and tuple-like --- records match. -sortFields :: M.Map Name a -> [(Name,a)] -sortFields l = map snd $ sortOn fst $ zip (map (fieldish . fst) l') l' - where l' = M.toList l - fieldish s = case reads $ nameToString s of - [(x, "")] -> Left (x::Int) - _ -> Right s -sortConstrs :: M.Map Name a -> [(Name, a)] -sortConstrs cs = sortOn fst $ M.toList cs - -isTypeParam :: TypeParamBase vn -> Bool -isTypeParam TypeParamType{} = True -isTypeParam TypeParamDim{} = False - -isSizeParam :: TypeParamBase vn -> Bool -isSizeParam = not . isTypeParam - --- | Combine the shape information of types as much as possible. The first --- argument is the orignal type and the second is the type of the transformed --- expression. This is necessary since the original type may contain additional --- information (e.g., shape restrictions) from the user given annotation. -combineTypeShapes :: (Monoid as, ArrayDim dim) => - TypeBase dim as -> TypeBase dim as -> TypeBase dim as -combineTypeShapes (Scalar (Record ts1)) (Scalar (Record ts2)) - | M.keys ts1 == M.keys ts2 = - Scalar $ Record $ M.map (uncurry combineTypeShapes) (M.intersectionWith (,) ts1 ts2) -combineTypeShapes (Scalar (Arrow als1 p1 a1 b1)) (Scalar (Arrow als2 _p2 a2 b2)) = - Scalar $ Arrow (als1<>als2) p1 (combineTypeShapes a1 a2) (combineTypeShapes b1 b2) -combineTypeShapes (Array als1 u1 et1 shape1) (Array als2 _u2 et2 _shape2) = - arrayOfWithAliases (combineTypeShapes (Scalar et1) (Scalar et2) - `setAliases` mempty) - (als1<>als2) shape1 u1 -combineTypeShapes _ new_tp = new_tp - --- | Match the dimensions of otherwise assumed-equal types. -matchDims :: (Monoid as, Monad m) => - (d1 -> d2 -> m d1) - -> TypeBase d1 as -> TypeBase d2 as - -> m (TypeBase d1 as) -matchDims onDims t1 t2 = - case (t1, t2) of - (Array als1 u1 et1 shape1, Array als2 u2 et2 shape2) -> - flip setAliases (als1<>als2) <$> - (arrayOf <$> - matchDims onDims (Scalar et1) (Scalar et2) <*> - onShapes shape1 shape2 <*> pure (min u1 u2)) - (Scalar (Record f1), Scalar (Record f2)) -> - Scalar . Record <$> - traverse (uncurry (matchDims onDims)) (M.intersectionWith (,) f1 f2) - (Scalar (Sum cs1), Scalar (Sum cs2)) -> - Scalar . Sum <$> - traverse (traverse (uncurry (matchDims onDims))) - (M.intersectionWith zip cs1 cs2) - (Scalar (Arrow als1 p1 a1 b1), Scalar (Arrow als2 _p2 a2 b2)) -> - Scalar <$> - (Arrow (als1 <> als2) p1 <$> matchDims onDims a1 a2 <*> matchDims onDims b1 b2) - (Scalar (TypeVar als1 u v targs1), - Scalar (TypeVar als2 _ _ targs2)) -> - Scalar . TypeVar (als1 <> als2) u v <$> zipWithM matchTypeArg targs1 targs2 - _ -> return t1 - - where matchTypeArg ta@TypeArgType{} _ = return ta - matchTypeArg a _ = return a - - onShapes shape1 shape2 = - ShapeDecl <$> zipWithM onDims (shapeDims shape1) (shapeDims shape2) - - --- | Set the uniqueness attribute of a type. If the type is a record --- or sum type, the uniqueness of its components will be modified. -setUniqueness :: TypeBase dim as -> Uniqueness -> TypeBase dim as -setUniqueness (Array als _ et shape) u = - Array als u et shape -setUniqueness (Scalar (TypeVar als _ t targs)) u = - Scalar $ TypeVar als u t targs -setUniqueness (Scalar (Record ets)) u = - Scalar $ Record $ fmap (`setUniqueness` u) ets -setUniqueness (Scalar (Sum ets)) u = - Scalar $ Sum $ fmap (map (`setUniqueness` u)) ets -setUniqueness t _ = t - --- | @t \`setAliases\` als@ returns @t@, but with @als@ substituted for --- any already present aliasing. -setAliases :: TypeBase dim asf -> ast -> TypeBase dim ast -setAliases t = addAliases t . const - --- | @t \`addAliases\` f@ returns @t@, but with any already present --- aliasing replaced by @f@ applied to that aliasing. -addAliases :: TypeBase dim asf -> (asf -> ast) - -> TypeBase dim ast -addAliases = flip second - -intValueType :: IntValue -> IntType -intValueType Int8Value{} = Int8 -intValueType Int16Value{} = Int16 -intValueType Int32Value{} = Int32 -intValueType Int64Value{} = Int64 - -floatValueType :: FloatValue -> FloatType -floatValueType Float32Value{} = Float32 -floatValueType Float64Value{} = Float64 - --- | The type of a basic value. -primValueType :: PrimValue -> PrimType -primValueType (SignedValue v) = Signed $ intValueType v -primValueType (UnsignedValue v) = Unsigned $ intValueType v -primValueType (FloatValue v) = FloatType $ floatValueType v -primValueType BoolValue{} = Bool - --- | The type of the value. -valueType :: Value -> ValueType -valueType (PrimValue bv) = Scalar $ Prim $ primValueType bv -valueType (ArrayValue _ t) = t - --- | The size of values of this type, in bytes. -primByteSize :: Num a => PrimType -> a -primByteSize (Signed it) = Primitive.intByteSize it -primByteSize (Unsigned it) = Primitive.intByteSize it -primByteSize (FloatType ft) = Primitive.floatByteSize ft -primByteSize Bool = 1 - --- | Construct a 'ShapeDecl' with the given number of 'AnyDim' --- dimensions. -rank :: Int -> ShapeDecl (DimDecl VName) -rank n = ShapeDecl $ replicate n AnyDim - --- | The type is leaving a scope, so clean up any aliases that --- reference the bound variables, and turn any dimensions that name --- them into AnyDim instead. -unscopeType :: S.Set VName -> PatternType -> PatternType -unscopeType bound_here t = first onDim $ t `addAliases` S.map unbind - where unbind (AliasBound v) | v `S.member` bound_here = AliasFree v - unbind a = a - onDim (NamedDim qn) | qualLeaf qn `S.member` bound_here = AnyDim - onDim d = d - --- | Perform some operation on a given record field. Returns --- 'Nothing' if that field does not exist. -onRecordField :: (TypeBase dim als -> TypeBase dim als) - -> [Name] - -> TypeBase dim als -> Maybe (TypeBase dim als) -onRecordField f [] t = Just $ f t -onRecordField f (k:ks) (Scalar (Record m)) = do - t <- onRecordField f ks =<< M.lookup k m - Just $ Scalar $ Record $ M.insert k t m -onRecordField _ _ _ = Nothing - --- | The type of an Futhark term. The aliasing will refer to itself, if --- the term is a non-tuple-typed variable. -typeOf :: ExpBase Info VName -> PatternType -typeOf (Literal val _) = Scalar $ Prim $ primValueType val -typeOf (IntLit _ (Info t) _) = t -typeOf (FloatLit _ (Info t) _) = t -typeOf (Parens e _) = typeOf e -typeOf (QualParens _ e _) = typeOf e -typeOf (TupLit es _) = tupleRecord $ map typeOf es -typeOf (RecordLit fs _) = - -- Reverse, because M.unions is biased to the left. - Scalar $ Record $ M.unions $ reverse $ map record fs - where record (RecordFieldExplicit name e _) = M.singleton name $ typeOf e - record (RecordFieldImplicit name (Info t) _) = - M.singleton (baseName name) $ t - `addAliases` S.insert (AliasBound name) -typeOf (ArrayLit _ (Info t) _) = t -typeOf (StringLit vs _) = - Array mempty Unique (Prim (Unsigned Int8)) - (ShapeDecl [ConstDim $ genericLength vs]) -typeOf (Range _ _ _ (Info t, _) _) = t -typeOf (BinOp _ _ _ _ (Info t) _ _) = t -typeOf (Project _ _ (Info t) _) = t -typeOf (If _ _ _ (Info t, _) _) = t -typeOf (Var _ (Info t) _) = t -typeOf (Ascript e _ _) = typeOf e -typeOf (Coerce _ _ (Info t, _) _) = t -typeOf (Apply _ _ _ (Info t, _) _) = t -typeOf (Negate e _) = typeOf e -typeOf (LetPat _ _ _ (Info t, _) _) = t -typeOf (LetFun _ _ _ (Info t) _) = t -typeOf (LetWith _ _ _ _ _ (Info t) _) = t -typeOf (Index _ _ (Info t, _) _) = t -typeOf (Update e _ _ _) = typeOf e `setAliases` mempty -typeOf (RecordUpdate _ _ _ (Info t) _) = t -typeOf (Unsafe e _) = typeOf e -typeOf (Assert _ e _ _) = typeOf e -typeOf (DoLoop _ _ _ _ _ (Info (t, _)) _) = t -typeOf (Lambda params _ _ (Info (als, t)) _) = - unscopeType bound_here $ foldr (arrow . patternParam) t params `setAliases` als - where bound_here = S.map identName (mconcat $ map patternIdents params) `S.difference` - S.fromList (mapMaybe (named . patternParam) params) - arrow (px, tx) y = Scalar $ Arrow () px tx y - named (Named x, _) = Just x - named (Unnamed, _) = Nothing -typeOf (OpSection _ (Info t) _) = - t -typeOf (OpSectionLeft _ _ _ (_, Info pt2) (Info ret, _) _) = - foldFunType [fromStruct pt2] ret -typeOf (OpSectionRight _ _ _ (Info pt1, _) (Info ret) _) = - foldFunType [fromStruct pt1] ret -typeOf (ProjectSection _ (Info t) _) = t -typeOf (IndexSection _ (Info t) _) = t -typeOf (Constr _ _ (Info t) _) = t -typeOf (Match _ cs (Info t, _) _) = - unscopeType (foldMap unscopeSet cs) t - where unscopeSet (CasePat p _ _) = S.map identName $ patternIdents p - --- | @foldFunType ts ret@ creates a function type ('Arrow') that takes --- @ts@ as parameters and returns @ret@. -foldFunType :: Monoid as => [TypeBase dim as] -> TypeBase dim as -> TypeBase dim as -foldFunType ps ret = foldr arrow ret ps - where arrow t1 t2 = Scalar $ Arrow mempty Unnamed t1 t2 - --- | Extract the parameter types and return type from a type. --- If the type is not an arrow type, the list of parameter types is empty. -unfoldFunType :: TypeBase dim as -> ([TypeBase dim as], TypeBase dim as) -unfoldFunType (Scalar (Arrow _ _ t1 t2)) = - let (ps, r) = unfoldFunType t2 - in (t1 : ps, r) -unfoldFunType t = ([], t) - --- | The type names mentioned in a type. -typeVars :: Monoid as => TypeBase dim as -> S.Set VName -typeVars t = - case t of - Scalar Prim{} -> mempty - Scalar (TypeVar _ _ tn targs) -> - mconcat $ typeVarFree tn : map typeArgFree targs - Scalar (Arrow _ _ t1 t2) -> typeVars t1 <> typeVars t2 - Scalar (Record fields) -> foldMap typeVars fields - Scalar (Sum cs) -> mconcat $ (foldMap . fmap) typeVars cs - Array _ _ rt _ -> typeVars $ Scalar rt - where typeVarFree = S.singleton . typeLeaf - typeArgFree (TypeArgType ta _) = typeVars ta - typeArgFree TypeArgDim{} = mempty - --- | @orderZero t@ is 'True' if the argument type has order 0, i.e., it is not --- a function type, does not contain a function type as a subcomponent, and may --- not be instantiated with a function type. -orderZero :: TypeBase dim as -> Bool -orderZero Array{} = True -orderZero (Scalar (Prim _)) = True -orderZero (Scalar (Record fs)) = all orderZero $ M.elems fs -orderZero (Scalar TypeVar{}) = True -orderZero (Scalar Arrow{}) = False -orderZero (Scalar (Sum cs)) = all (all orderZero) cs - --- | Extract all the shape names that occur in a given pattern. -patternDimNames :: PatternBase Info VName -> S.Set VName -patternDimNames (TuplePattern ps _) = foldMap patternDimNames ps -patternDimNames (RecordPattern fs _) = foldMap (patternDimNames . snd) fs -patternDimNames (PatternParens p _) = patternDimNames p -patternDimNames (Id _ (Info tp) _) = typeDimNames tp -patternDimNames (Wildcard (Info tp) _) = typeDimNames tp -patternDimNames (PatternAscription p (TypeDecl _ (Info t)) _) = - patternDimNames p <> typeDimNames t -patternDimNames (PatternLit _ (Info tp) _) = typeDimNames tp -patternDimNames (PatternConstr _ _ ps _) = foldMap patternDimNames ps - --- | Extract all the shape names that occur in a given type. -typeDimNames :: TypeBase (DimDecl VName) als -> S.Set VName -typeDimNames = foldMap dimName . nestedDims - where dimName :: DimDecl VName -> S.Set VName - dimName (NamedDim qn) = S.singleton $ qualLeaf qn - dimName _ = mempty - --- | @patternOrderZero pat@ is 'True' if all of the types in the given pattern --- have order 0. -patternOrderZero :: PatternBase Info vn -> Bool -patternOrderZero pat = case pat of - TuplePattern ps _ -> all patternOrderZero ps - RecordPattern fs _ -> all (patternOrderZero . snd) fs - PatternParens p _ -> patternOrderZero p - Id _ (Info t) _ -> orderZero t - Wildcard (Info t) _ -> orderZero t - PatternAscription p _ _ -> patternOrderZero p - PatternLit _ (Info t) _ -> orderZero t - PatternConstr _ _ ps _ -> all patternOrderZero ps - --- | The set of identifiers bound in a pattern. -patternIdents :: (Functor f, Ord vn) => PatternBase f vn -> S.Set (IdentBase f vn) -patternIdents (Id v t loc) = S.singleton $ Ident v t loc -patternIdents (PatternParens p _) = patternIdents p -patternIdents (TuplePattern pats _) = mconcat $ map patternIdents pats -patternIdents (RecordPattern fs _) = mconcat $ map (patternIdents . snd) fs -patternIdents Wildcard{} = mempty -patternIdents (PatternAscription p _ _) = patternIdents p -patternIdents PatternLit{} = mempty -patternIdents (PatternConstr _ _ ps _ ) = mconcat $ map patternIdents ps - --- | The set of names bound in a pattern. -patternNames :: (Functor f, Ord vn) => PatternBase f vn -> S.Set vn -patternNames (Id v _ _) = S.singleton v -patternNames (PatternParens p _) = patternNames p -patternNames (TuplePattern pats _) = mconcat $ map patternNames pats -patternNames (RecordPattern fs _) = mconcat $ map (patternNames . snd) fs -patternNames Wildcard{} = mempty -patternNames (PatternAscription p _ _) = patternNames p -patternNames PatternLit{} = mempty -patternNames (PatternConstr _ _ ps _ ) = mconcat $ map patternNames ps - --- | A mapping from names bound in a map to their identifier. -patternMap :: (Functor f) => PatternBase f VName -> M.Map VName (IdentBase f VName) -patternMap pat = - M.fromList $ zip (map identName idents) idents - where idents = S.toList $ patternIdents pat - --- | The type of values bound by the pattern. -patternType :: PatternBase Info VName -> PatternType -patternType (Wildcard (Info t) _) = t -patternType (PatternParens p _) = patternType p -patternType (Id _ (Info t) _) = t -patternType (TuplePattern pats _) = tupleRecord $ map patternType pats -patternType (RecordPattern fs _) = Scalar $ Record $ patternType <$> M.fromList fs -patternType (PatternAscription p _ _) = patternType p -patternType (PatternLit _ (Info t) _) = t -patternType (PatternConstr _ (Info t) _ _) = t - --- | The type matched by the pattern, including shape declarations if present. -patternStructType :: PatternBase Info VName -> StructType -patternStructType = toStruct . patternType - --- | When viewed as a function parameter, does this pattern correspond --- to a named parameter of some type? -patternParam :: PatternBase Info VName -> (PName, StructType) -patternParam (PatternParens p _) = - patternParam p -patternParam (PatternAscription (Id v _ _) td _) = - (Named v, unInfo $ expandedType td) -patternParam (Id v (Info t) _) = - (Named v, toStruct t) -patternParam p = - (Unnamed, patternStructType p) - --- | Names of primitive types to types. This is only valid if no --- shadowing is going on, but useful for tools. -namesToPrimTypes :: M.Map Name PrimType -namesToPrimTypes = M.fromList - [ (nameFromString $ pretty t, t) | - t <- Bool : - map Signed [minBound..maxBound] ++ - map Unsigned [minBound..maxBound] ++ - map FloatType [minBound..maxBound] ] - --- | The nature of something predefined. These can either be --- monomorphic or overloaded. An overloaded builtin is a list valid --- types it can be instantiated with, to the parameter and result --- type, with 'Nothing' representing the overloaded parameter type. -data Intrinsic = IntrinsicMonoFun [PrimType] PrimType - | IntrinsicOverloadedFun [PrimType] [Maybe PrimType] (Maybe PrimType) - | IntrinsicPolyFun [TypeParamBase VName] [StructType] StructType - | IntrinsicType PrimType - | IntrinsicEquality -- Special cased. - --- | A map of all built-ins. -intrinsics :: M.Map VName Intrinsic -intrinsics = M.fromList $ zipWith namify [10..] $ - - map primFun (M.toList Primitive.primFuns) ++ - - [("opaque", IntrinsicPolyFun [tp_a] [Scalar t_a] $ Scalar t_a)] ++ - - map unOpFun Primitive.allUnOps ++ - - map binOpFun Primitive.allBinOps ++ - - map cmpOpFun Primitive.allCmpOps ++ - - map convOpFun Primitive.allConvOps ++ - - map signFun Primitive.allIntTypes ++ - - map unsignFun Primitive.allIntTypes ++ - - map intrinsicType (map Signed [minBound..maxBound] ++ - map Unsigned [minBound..maxBound] ++ - map FloatType [minBound..maxBound] ++ - [Bool]) ++ - - -- This overrides the ! from Primitive. - [ ("!", IntrinsicOverloadedFun - (map Signed [minBound..maxBound] ++ - map Unsigned [minBound..maxBound] ++ - [Bool]) - [Nothing] Nothing) ] ++ - - -- The reason for the loop formulation is to ensure that we - -- get a missing case warning if we forget a case. - mapMaybe mkIntrinsicBinOp [minBound..maxBound] ++ - - [("flatten", IntrinsicPolyFun [tp_a] - [Array () Nonunique t_a (rank 2)] $ - Array () Nonunique t_a (rank 1)), - ("unflatten", IntrinsicPolyFun [tp_a] - [Scalar $ Prim $ Signed Int32, - Scalar $ Prim $ Signed Int32, - Array () Nonunique t_a (rank 1)] $ - Array () Nonunique t_a (rank 2)), - - ("concat", IntrinsicPolyFun [tp_a] - [arr_a, arr_a] uarr_a), - ("rotate", IntrinsicPolyFun [tp_a] - [Scalar $ Prim $ Signed Int32, arr_a] arr_a), - ("transpose", IntrinsicPolyFun [tp_a] [arr_2d_a] arr_2d_a), - - ("scatter", IntrinsicPolyFun [tp_a] - [Array () Unique t_a (rank 1), - Array () Nonunique (Prim $ Signed Int32) (rank 1), - Array () Nonunique t_a (rank 1)] $ - Array () Unique t_a (rank 1)), - - ("zip", IntrinsicPolyFun [tp_a, tp_b] [arr_a, arr_b] arr_a_b), - ("unzip", IntrinsicPolyFun [tp_a, tp_b] [arr_a_b] t_arr_a_arr_b), - - ("hist", IntrinsicPolyFun [tp_a] - [Scalar $ Prim $ Signed Int32, - uarr_a, - Scalar t_a `arr` (Scalar t_a `arr` Scalar t_a), - Scalar t_a, - Array () Nonunique (Prim $ Signed Int32) (rank 1), - arr_a] - uarr_a), - - ("map", IntrinsicPolyFun [tp_a, tp_b] [Scalar t_a `arr` Scalar t_b, arr_a] uarr_b), - - ("reduce", IntrinsicPolyFun [tp_a] - [Scalar t_a `arr` (Scalar t_a `arr` Scalar t_a), Scalar t_a, arr_a] $ - Scalar t_a), - - ("reduce_comm", IntrinsicPolyFun [tp_a] - [Scalar t_a `arr` (Scalar t_a `arr` Scalar t_a), Scalar t_a, arr_a] $ - Scalar t_a), - - ("scan", IntrinsicPolyFun [tp_a] - [Scalar t_a `arr` (Scalar t_a `arr` Scalar t_a), Scalar t_a, arr_a] uarr_a), - - ("partition", - IntrinsicPolyFun [tp_a] - [Scalar (Prim $ Signed Int32), - Scalar t_a `arr` Scalar (Prim $ Signed Int32), arr_a] $ - tupleRecord [uarr_a, Array () Unique (Prim $ Signed Int32) (rank 1)]), - - ("map_stream", - IntrinsicPolyFun [tp_a, tp_b] - [Scalar (Prim $ Signed Int32) `karr` (arr_ka `arr` arr_kb), arr_a] - uarr_b), - - ("map_stream_per", - IntrinsicPolyFun [tp_a, tp_b] - [Scalar (Prim $ Signed Int32) `karr` (arr_ka `arr` arr_kb), arr_a] - uarr_b), - - ("reduce_stream", - IntrinsicPolyFun [tp_a, tp_b] - [Scalar t_b `arr` (Scalar t_b `arr` Scalar t_b), - Scalar (Prim $ Signed Int32) `karr` (arr_ka `arr` Scalar t_b), - arr_a] $ - Scalar t_b), - - ("reduce_stream_per", - IntrinsicPolyFun [tp_a, tp_b] - [Scalar t_b `arr` (Scalar t_b `arr` Scalar t_b), - Scalar (Prim $ Signed Int32) `karr` (arr_ka `arr` Scalar t_b), - arr_a] $ - Scalar t_b), - - ("trace", IntrinsicPolyFun [tp_a] [Scalar t_a] $ Scalar t_a), - ("break", IntrinsicPolyFun [tp_a] [Scalar t_a] $ Scalar t_a)] - - where tv_a = VName (nameFromString "a") 0 - t_a = TypeVar () Nonunique (typeName tv_a) [] - arr_a = Array () Nonunique t_a (rank 1) - arr_2d_a = Array () Nonunique t_a (rank 2) - uarr_a = Array () Unique t_a (rank 1) - tp_a = TypeParamType Unlifted tv_a noLoc - - tv_b = VName (nameFromString "b") 1 - t_b = TypeVar () Nonunique (typeName tv_b) [] - arr_b = Array () Nonunique t_b (rank 1) - uarr_b = Array () Unique t_b (rank 1) - tp_b = TypeParamType Unlifted tv_b noLoc - - arr_a_b = Array () Nonunique - (Record (M.fromList $ zip tupleFieldNames [Scalar t_a, Scalar t_b])) - (rank 1) - t_arr_a_arr_b = Scalar $ Record $ M.fromList $ zip tupleFieldNames [arr_a, arr_b] - - arr x y = Scalar $ Arrow mempty Unnamed x y - - kv = VName (nameFromString "k") 2 - arr_ka = Array () Nonunique t_a (ShapeDecl [NamedDim $ qualName kv]) - arr_kb = Array () Nonunique t_b (ShapeDecl [NamedDim $ qualName kv]) - karr x y = Scalar $ Arrow mempty (Named kv) x y - - namify i (k,v) = (VName (nameFromString k) i, v) - - primFun (name, (ts,t, _)) = - (name, IntrinsicMonoFun (map unPrim ts) $ unPrim t) - - unOpFun bop = (pretty bop, IntrinsicMonoFun [t] t) - where t = unPrim $ Primitive.unOpType bop - - binOpFun bop = (pretty bop, IntrinsicMonoFun [t, t] t) - where t = unPrim $ Primitive.binOpType bop - - cmpOpFun bop = (pretty bop, IntrinsicMonoFun [t, t] Bool) - where t = unPrim $ Primitive.cmpOpType bop - - convOpFun cop = (pretty cop, IntrinsicMonoFun [unPrim ft] $ unPrim tt) - where (ft, tt) = Primitive.convOpType cop - - signFun t = ("sign_" ++ pretty t, IntrinsicMonoFun [Unsigned t] $ Signed t) - - unsignFun t = ("unsign_" ++ pretty t, IntrinsicMonoFun [Signed t] $ Unsigned t) - - unPrim (Primitive.IntType t) = Signed t - unPrim (Primitive.FloatType t) = FloatType t - unPrim Primitive.Bool = Bool - unPrim Primitive.Cert = Bool - - intrinsicType t = (pretty t, IntrinsicType t) - - anyIntType = map Signed [minBound..maxBound] ++ - map Unsigned [minBound..maxBound] - anyNumberType = anyIntType ++ - map FloatType [minBound..maxBound] - anyPrimType = Bool : anyNumberType - - mkIntrinsicBinOp :: BinOp -> Maybe (String, Intrinsic) - mkIntrinsicBinOp op = do op' <- intrinsicBinOp op - return (pretty op, op') - - binOp ts = Just $ IntrinsicOverloadedFun ts [Nothing, Nothing] Nothing - ordering = Just $ IntrinsicOverloadedFun anyPrimType [Nothing, Nothing] (Just Bool) - - intrinsicBinOp Plus = binOp anyNumberType - intrinsicBinOp Minus = binOp anyNumberType - intrinsicBinOp Pow = binOp anyNumberType - intrinsicBinOp Times = binOp anyNumberType - intrinsicBinOp Divide = binOp anyNumberType - intrinsicBinOp Mod = binOp anyNumberType - intrinsicBinOp Quot = binOp anyIntType - intrinsicBinOp Rem = binOp anyIntType - intrinsicBinOp ShiftR = binOp anyIntType - intrinsicBinOp ShiftL = binOp anyIntType - intrinsicBinOp Band = binOp anyIntType - intrinsicBinOp Xor = binOp anyIntType - intrinsicBinOp Bor = binOp anyIntType - intrinsicBinOp LogAnd = binOp [Bool] - intrinsicBinOp LogOr = binOp [Bool] - intrinsicBinOp Equal = Just IntrinsicEquality - intrinsicBinOp NotEqual = Just IntrinsicEquality - intrinsicBinOp Less = ordering - intrinsicBinOp Leq = ordering - intrinsicBinOp Greater = ordering - intrinsicBinOp Geq = ordering - intrinsicBinOp _ = Nothing - --- | The largest tag used by an intrinsic - this can be used to --- determine whether a 'VName' refers to an intrinsic or a user-defined name. -maxIntrinsicTag :: Int -maxIntrinsicTag = maximum $ map baseTag $ M.keys intrinsics - --- | Create a name with no qualifiers from a name. -qualName :: v -> QualName v -qualName = QualName [] - --- | Add another qualifier (at the head) to a qualified name. -qualify :: v -> QualName v -> QualName v -qualify k (QualName ks v) = QualName (k:ks) v - --- | Create a type name name with no qualifiers from a 'VName'. -typeName :: VName -> TypeName -typeName = typeNameFromQualName . qualName - --- | The modules imported by a Futhark program. -progImports :: ProgBase f vn -> [(String,SrcLoc)] -progImports = concatMap decImports . progDecs - --- | The modules imported by a single declaration. -decImports :: DecBase f vn -> [(String,SrcLoc)] -decImports (OpenDec x _) = modExpImports x -decImports (ModDec md) = modExpImports $ modExp md -decImports SigDec{} = [] -decImports TypeDec{} = [] -decImports ValDec{} = [] -decImports (LocalDec d _) = decImports d -decImports (ImportDec x _ loc) = [(x, loc)] - -modExpImports :: ModExpBase f vn -> [(String,SrcLoc)] -modExpImports ModVar{} = [] -modExpImports (ModParens p _) = modExpImports p -modExpImports (ModImport f _ loc) = [(f,loc)] -modExpImports (ModDecs ds _) = concatMap decImports ds -modExpImports (ModApply _ me _ _ _) = modExpImports me -modExpImports (ModAscript me _ _ _) = modExpImports me -modExpImports ModLambda{} = [] - --- | The set of module types used in any exported (non-local) --- declaration. -progModuleTypes :: Ord vn => ProgBase f vn -> S.Set vn -progModuleTypes = mconcat . map onDec . progDecs - where onDec (OpenDec x _) = onModExp x - onDec (ModDec md) = - maybe mempty (onSigExp . fst) (modSignature md) <> onModExp (modExp md) - onDec SigDec{} = mempty - onDec TypeDec{} = mempty - onDec ValDec{} = mempty - onDec LocalDec{} = mempty - onDec ImportDec{} = mempty - - onModExp ModVar{} = mempty - onModExp (ModParens p _) = onModExp p - onModExp ModImport {} = mempty - onModExp (ModDecs ds _) = mconcat $ map onDec ds - onModExp (ModApply me1 me2 _ _ _) = onModExp me1 <> onModExp me2 - onModExp (ModAscript me se _ _) = onModExp me <> onSigExp se - onModExp (ModLambda p r me _) = - onModParam p <> maybe mempty (onSigExp . fst) r <> onModExp me - - onModParam = onSigExp . modParamType - - onSigExp (SigVar v _ _) = S.singleton $ qualLeaf v - onSigExp (SigParens e _) = onSigExp e - onSigExp SigSpecs{} = mempty - onSigExp (SigWith e _ _) = onSigExp e - onSigExp (SigArrow _ e1 e2 _) = onSigExp e1 <> onSigExp e2 - --- | Extract a leading @((name, namespace, file), remainder)@ from a --- documentation comment string. These are formatted as --- \`name\`\@namespace[\@file]. Let us hope that this pattern does not occur --- anywhere else. -identifierReference :: String -> Maybe ((String, String, Maybe FilePath), String) -identifierReference ('`' : s) - | (identifier, '`' : '@' : s') <- break (=='`') s, - (namespace, s'') <- span isAlpha s', - not $ null namespace = - case s'' of - '@' : '"' : s''' - | (file, '"' : s'''') <- span (/= '"') s''' -> - Just ((identifier, namespace, Just file), s'''') - _ -> Just ((identifier, namespace, Nothing), s'') - -identifierReference _ = Nothing - --- | Given an operator name, return the operator that determines its --- syntactical properties. -leadingOperator :: Name -> BinOp -leadingOperator s = maybe Backtick snd $ find ((`isPrefixOf` s') . fst) $ - sortOn (Down . length . fst) $ - zip (map pretty operators) operators - where s' = nameToString s - operators :: [BinOp] - operators = [minBound..maxBound::BinOp] - --- | A type with no aliasing information but shape annotations. -type UncheckedType = TypeBase (ShapeDecl Name) () - -type UncheckedTypeExp = TypeExp Name - --- | A type declaration with no expanded type. -type UncheckedTypeDecl = TypeDeclBase NoInfo Name - --- | An identifier with no type annotations. -type UncheckedIdent = IdentBase NoInfo Name - --- | An index with no type annotations. -type UncheckedDimIndex = DimIndexBase NoInfo Name - --- | An expression with no type annotations. -type UncheckedExp = ExpBase NoInfo Name - --- | A module expression with no type annotations. -type UncheckedModExp = ModExpBase NoInfo Name - --- | A module type expression with no type annotations. -type UncheckedSigExp = SigExpBase NoInfo Name - --- | A type parameter with no type annotations. -type UncheckedTypeParam = TypeParamBase Name - --- | A pattern with no type annotations. -type UncheckedPattern = PatternBase NoInfo Name - --- | A function declaration with no type annotations. -type UncheckedValBind = ValBindBase NoInfo Name - --- | A declaration with no type annotations. -type UncheckedDec = DecBase NoInfo Name - --- | A Futhark program with no type annotations. -type UncheckedProg = ProgBase NoInfo Name - --- | A case (of a match expression) with no type annotations. -type UncheckedCase = CaseBase NoInfo Name diff --git a/src/Language/Futhark/Core.hs b/src/Language/Futhark/Core.hs --- a/src/Language/Futhark/Core.hs +++ b/src/Language/Futhark/Core.hs @@ -1,16 +1,18 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE Strict #-} -{-# LANGUAGE StrictData #-} +{-# LANGUAGE Trustworthy #-} -- | This module contains very basic definitions for Futhark - so basic, -- that they can be shared between the internal and external -- representation. module Language.Futhark.Core ( Uniqueness(..) - , StreamOrd(..) , Commutativity(..) -- * Location utilities + , SrcLoc + , Loc + , Located(..) + , srclocOf , locStr , locStrRel , prettyStacktrace @@ -42,10 +44,10 @@ import Data.Int (Int8, Int16, Int32, Int64) import Data.String import Data.Word (Word8, Word16, Word32, Word64) -import Data.Loc import qualified Data.Text as T import Futhark.Util.Pretty +import Futhark.Util.Loc -- | The uniqueness attribute of a type. This essentially indicates -- whether or not in-place modifications are acceptable. With respect @@ -63,10 +65,6 @@ instance Pretty Uniqueness where ppr Unique = star ppr Nonunique = empty - -data StreamOrd = InOrder - | Disorder - deriving (Eq, Ord, Show) -- | Whether some operator is commutative or not. The 'Monoid' -- instance returns the least commutative of its arguments. diff --git a/src/Language/Futhark/Interpreter.hs b/src/Language/Futhark/Interpreter.hs --- a/src/Language/Futhark/Interpreter.hs +++ b/src/Language/Futhark/Interpreter.hs @@ -1,7 +1,8 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE OverloadedStrings #-} +-- | An interpreter operating on type-checked source Futhark terms. +-- Relatively slow. module Language.Futhark.Interpreter ( Ctx(..) , Env @@ -33,16 +34,16 @@ import qualified Data.Map as M import qualified Data.List.NonEmpty as NE import Data.Monoid hiding (Sum) -import Data.Loc import Language.Futhark hiding (Value, matchDims) import qualified Language.Futhark as F -import Futhark.Representation.Primitive (intValue, floatValue) -import qualified Futhark.Representation.Primitive as P +import Futhark.IR.Primitive (intValue, floatValue) +import qualified Futhark.IR.Primitive as P import qualified Language.Futhark.Semantic as T import Futhark.Util.Pretty hiding (apply, bool) import Futhark.Util (chunk, splitFromEnd, maybeHead) +import Futhark.Util.Loc import Prelude hiding (mod, break) @@ -332,6 +333,7 @@ data Module = Module Env | ModuleFun (Module -> EvalM Module) +-- | The actual type- and value environment. data Env = Env { envTerm :: M.Map VName TermBinding , envType :: M.Map VName T.TypeBinding , envShapes :: M.Map VName ValueShape @@ -346,6 +348,9 @@ Env vm1 tm1 sm1 <> Env vm2 tm2 sm2 = Env (vm1 <> vm2) (tm1 <> tm2) (sm1 <> sm2) +-- | An error occurred during interpretation due to an error in the +-- user program. Actual interpreter errors will be signaled with an +-- IO exception ('error'). newtype InterpreterError = InterpreterError String valEnv :: M.Map VName (Maybe T.BoundV, Value) -> Env @@ -386,7 +391,7 @@ -- actual call to 'implicits.trace' is going to be in the trace -- function in the prelude, which is not interesting. top <- fromMaybe noLoc . maybeHead . drop 1 <$> stacktrace - liftF $ ExtOpTrace top (pretty v) () + liftF $ ExtOpTrace top (prettyOneLine v) () typeCheckerEnv :: Env -> T.Env typeCheckerEnv env = @@ -987,6 +992,8 @@ Just v' -> return v' Nothing -> match v cs' +eval env (Attr _ e _) = eval env e + evalCase :: Value -> Env -> CaseBase Info VName -> EvalM (Maybe Value) evalCase v env (CasePat p cExp _) = runMaybeT $ do @@ -1090,6 +1097,9 @@ wrapInLambda [p] = ModLambda p ret body loc wrapInLambda (p:ps') = ModLambda p Nothing (wrapInLambda ps') loc +-- | The interpreter context. All evaluation takes place with respect +-- to a context, and it can be extended with more definitions, which +-- is how the REPL works. data Ctx = Ctx { ctxEnv :: Env , ctxImports :: M.Map FilePath Env } diff --git a/src/Language/Futhark/Parser.hs b/src/Language/Futhark/Parser.hs --- a/src/Language/Futhark/Parser.hs +++ b/src/Language/Futhark/Parser.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE Safe #-} -- | Interface to the Futhark parser. module Language.Futhark.Parser ( parseFuthark @@ -21,7 +22,7 @@ import qualified Data.Text as T import Language.Futhark.Syntax -import Language.Futhark.Attributes +import Language.Futhark.Prop import Language.Futhark.Parser.Parser import Language.Futhark.Parser.Lexer diff --git a/src/Language/Futhark/Parser/Lexer.x b/src/Language/Futhark/Parser/Lexer.x --- a/src/Language/Futhark/Parser/Lexer.x +++ b/src/Language/Futhark/Parser/Lexer.x @@ -1,6 +1,7 @@ { {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE Trustworthy #-} {-# OPTIONS_GHC -w #-} -- | The Futhark lexer. Takes a string, produces a list of tokens with position information. module Language.Futhark.Parser.Lexer @@ -14,7 +15,6 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.Char (ord, toLower) -import Data.Loc hiding (L) import Data.Int (Int8, Int16, Int32, Int64) import Data.Word (Word8) import Data.Bits @@ -25,8 +25,9 @@ import Language.Futhark.Core (Int8, Int16, Int32, Int64, Word8, Word16, Word32, Word64, Name, nameFromText, nameToText) -import Language.Futhark.Attributes (leadingOperator) +import Language.Futhark.Prop (leadingOperator) import Language.Futhark.Syntax (BinOp(..)) +import Futhark.Util.Loc hiding (L) } @@ -84,6 +85,7 @@ "'^" { tokenC APOSTROPHE_THEN_HAT } "'~" { tokenC APOSTROPHE_THEN_TILDE } "`" { tokenC BACKTICK } + "#[" { tokenC HASH_LBRACKET } "..<" { tokenC TWO_DOTS_LT } "..>" { tokenC TWO_DOTS_GT } "..." { tokenC THREE_DOTS } @@ -328,6 +330,7 @@ | APOSTROPHE_THEN_HAT | APOSTROPHE_THEN_TILDE | BACKTICK + | HASH_LBRACKET | TWO_DOTS | TWO_DOTS_LT | TWO_DOTS_GT @@ -391,6 +394,8 @@ , alex_scd = 0}) of Left msg -> Left msg Right ( _, a ) -> Right a +-- | Given a starting position, produce tokens from the given text (or +-- a lexer error). Returns the final position. scanTokensText :: Pos -> T.Text -> Either String ([L Token], Pos) scanTokensText pos = scanTokens pos . BS.fromStrict . T.encodeUtf8 diff --git a/src/Language/Futhark/Parser/Parser.y b/src/Language/Futhark/Parser/Parser.y --- a/src/Language/Futhark/Parser/Parser.y +++ b/src/Language/Futhark/Parser/Parser.y @@ -1,6 +1,7 @@ { {-# LANGUAGE TupleSections #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Trustworthy #-} -- | Futhark parser written with Happy. module Language.Futhark.Parser.Parser ( prog @@ -28,16 +29,16 @@ import Codec.Binary.UTF8.String (encode) import Data.Char (ord) import Data.Maybe (fromMaybe, fromJust) -import Data.Loc hiding (L) -- Lexer has replacements. import Data.List (genericLength) import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as M import Data.Monoid import Language.Futhark.Syntax hiding (ID) -import Language.Futhark.Attributes +import Language.Futhark.Prop import Language.Futhark.Pretty import Language.Futhark.Parser.Lexer +import Futhark.Util.Loc hiding (L) -- Lexer has replacements. } @@ -138,6 +139,7 @@ '}' { L $$ RCURLY } '[' { L $$ LBRACKET } ']' { L $$ RBRACKET } + '#[' { L $$ HASH_LBRACKET } ',' { L $$ COMMA } '_' { L $$ UNDERSCORE } '\\' { L $$ BACKSLASH } @@ -546,8 +548,10 @@ | MatchExp { $1 } - | unsafe Exp2 { Unsafe $2 (srcspan $1 $>) } + | unsafe Exp2 { Unsafe $2 (srcspan $1 $>) } | assert Atom Atom { Assert $2 $3 NoInfo (srcspan $1 $>) } + | '#[' AttrInfo ']' Exp %prec bottom + { Attr $2 $4 (srcspan $1 $>) } | Exp2 '+...' Exp2 { binOp $1 $2 $3 } | Exp2 '-...' Exp2 { binOp $1 $2 $3 } @@ -881,6 +885,10 @@ maybeAscription(p) : ':' p { Just $2 } | { Nothing } + +AttrInfo :: { AttrInfo } + : id { let L _ (ID s) = $1 in AttrInfo s } + | unsafe { AttrInfo "unsafe" } -- HACK Value :: { Value } Value : IntValue { $1 } diff --git a/src/Language/Futhark/Prelude.hs b/src/Language/Futhark/Prelude.hs --- a/src/Language/Futhark/Prelude.hs +++ b/src/Language/Futhark/Prelude.hs @@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE Trustworthy #-} {-# LANGUAGE TemplateHaskell #-} -- | The Futhark Prelude Library embedded embedded as strings read -- during compilation of the Futhark compiler. The advantage is that diff --git a/src/Language/Futhark/Pretty.hs b/src/Language/Futhark/Pretty.hs --- a/src/Language/Futhark/Pretty.hs +++ b/src/Language/Futhark/Pretty.hs @@ -32,7 +32,7 @@ import Futhark.Util import Language.Futhark.Syntax -import Language.Futhark.Attributes +import Language.Futhark.Prop commastack :: [Doc] -> Doc commastack = align . stack . punctuate comma @@ -59,12 +59,13 @@ instance IsName Name where pprName = ppr +-- | Prettyprint a name to a string. prettyName :: IsName v => v -> String prettyName = prettyDoc 80 . pprName -- | Class for type constructors that represent annotations. Used in -- the prettyprinter to either print the original AST, or the computed --- attribute. +-- decoration. class Annot f where -- | Extract value, if any. unAnnot :: f a -> Maybe a @@ -272,6 +273,7 @@ LetWith{} -> True If{} -> True Match{} -> True + Attr{} -> True ArrayLit{} -> False _ -> hasArrayLit e pprPrec _ (LetFun fname (tparams, params, retdecl, rettype, e) body _ _) = @@ -325,6 +327,11 @@ indent 2 (ppr loopbody) pprPrec _ (Constr n cs _ _) = text "#" <> ppr n <+> sep (map ppr cs) pprPrec _ (Match e cs _ _) = text "match" <+> ppr e (stack . map ppr) (NE.toList cs) + pprPrec _ (Attr attr e _) = + text "#[" <> ppr attr <> text "]" <+/> pprPrec (-1) e + +instance Pretty AttrInfo where + ppr (AttrInfo attr) = ppr attr instance (Eq vn, IsName vn, Annot f) => Pretty (FieldBase f vn) where ppr (RecordFieldExplicit name e _) = ppr name <> equals <> ppr e diff --git a/src/Language/Futhark/Prop.hs b/src/Language/Futhark/Prop.hs new file mode 100644 --- /dev/null +++ b/src/Language/Futhark/Prop.hs @@ -0,0 +1,1056 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | This module provides various simple ways to query and manipulate +-- fundamental Futhark terms, such as types and values. The intent is to +-- keep "Futhark.Language.Syntax" simple, and put whatever embellishments +-- we need here. +module Language.Futhark.Prop + ( + -- * Various + Intrinsic(..) + , intrinsics + , maxIntrinsicTag + , namesToPrimTypes + , qualName + , qualify + , typeName + , valueType + , primValueType + , leadingOperator + , progImports + , decImports + , progModuleTypes + , identifierReference + , prettyStacktrace + + -- * Queries on expressions + , typeOf + + -- * Queries on patterns and params + , patternIdents + , patternNames + , patternMap + , patternType + , patternStructType + , patternParam + , patternOrderZero + , patternDimNames + + -- * Queries on types + , uniqueness + , unique + , aliases + , diet + , arrayRank + , arrayShape + , nestedDims + , orderZero + , unfoldFunType + , foldFunType + , typeVars + , typeDimNames + , primByteSize + + -- * Operations on types + , rank + , peelArray + , stripArray + , arrayOf + , toStructural + , toStruct + , fromStruct + , setAliases + , addAliases + , setUniqueness + , noSizes + , addSizes + , anySizes + , traverseDims + , DimPos(..) + , mustBeExplicit + , mustBeExplicitInType + , tupleRecord + , isTupleRecord + , areTupleFields + , tupleFields + , tupleFieldNames + , sortFields + , sortConstrs + , isTypeParam + , isSizeParam + , combineTypeShapes + , matchDims + , unscopeType + , onRecordField + + -- | Values of these types are produces by the parser. They use + -- unadorned names and have no type information, apart from that + -- which is syntactically required. + , NoInfo(..) + , UncheckedType + , UncheckedTypeExp + , UncheckedIdent + , UncheckedTypeDecl + , UncheckedDimIndex + , UncheckedExp + , UncheckedModExp + , UncheckedSigExp + , UncheckedTypeParam + , UncheckedPattern + , UncheckedValBind + , UncheckedDec + , UncheckedProg + , UncheckedCase + ) + where + +import Control.Monad.State +import Control.Monad.Writer hiding (Sum) +import Data.Char +import Data.Foldable +import qualified Data.Map.Strict as M +import qualified Data.Set as S +import Data.List (sortOn, genericLength, isPrefixOf, nub) +import Data.Maybe +import Data.Ord +import Data.Bifunctor +import Data.Bifoldable +import Data.Bitraversable (bitraverse) + +import Prelude + +import Futhark.Util.Pretty + +import Language.Futhark.Syntax +import qualified Futhark.IR.Primitive as Primitive + +-- | Return the dimensionality of a type. For non-arrays, this is +-- zero. For a one-dimensional array it is one, for a two-dimensional +-- it is two, and so forth. +arrayRank :: TypeBase dim as -> Int +arrayRank = shapeRank . arrayShape + +-- | Return the shape of a type - for non-arrays, this is 'mempty'. +arrayShape :: TypeBase dim as -> ShapeDecl dim +arrayShape (Array _ _ _ ds) = ds +arrayShape _ = mempty + +-- | Return any shape declarations in the type, with duplicates +-- removed. +nestedDims :: TypeBase (DimDecl VName) as -> [DimDecl VName] +nestedDims t = + case t of Array _ _ a ds -> + nub $ nestedDims (Scalar a) <> shapeDims ds + Scalar (Record fs) -> + nub $ foldMap nestedDims fs + Scalar Prim{} -> + mempty + Scalar (Sum cs) -> + nub $ foldMap (foldMap nestedDims) cs + Scalar (Arrow _ v t1 t2) -> + filter (notV v) $ nestedDims t1 <> nestedDims t2 + Scalar (TypeVar _ _ _ targs) -> + concatMap typeArgDims targs + + where typeArgDims (TypeArgDim d _) = [d] + typeArgDims (TypeArgType at _) = nestedDims at + + notV Unnamed = const True + notV (Named v) = (/=NamedDim (qualName v)) + +-- | Change the shape of a type to be just the rank. +noSizes :: TypeBase (DimDecl vn) as -> TypeBase () as +noSizes = first $ const () + +-- | Add size annotations that are all 'AnyDim'. +addSizes :: TypeBase () as -> TypeBase (DimDecl vn) as +addSizes = first $ const AnyDim + +-- | Change all size annotations to be 'AnyDim'. +anySizes :: TypeBase (DimDecl vn) as -> TypeBase (DimDecl vn) as +anySizes = first $ const AnyDim + +-- | Where does this dimension occur? +data DimPos + = PosImmediate + -- ^ Immediately in the argument to 'traverseDims'. + | PosParam + -- ^ In a function parameter type. + | PosReturn + -- ^ In a function return type. + deriving (Eq, Ord, Show) + +-- | Perform a traversal (possibly including replacement) on sizes +-- that are parameters in a function type, but also including the type +-- immediately passed to the function. +traverseDims :: forall f fdim tdim als. + Applicative f => + (DimPos -> fdim -> f tdim) + -> TypeBase fdim als + -> f (TypeBase tdim als) +traverseDims f = go PosImmediate + where go :: forall als'. DimPos -> TypeBase fdim als' -> f (TypeBase tdim als') + go b t@Array{} = bitraverse (f b) pure t + go b (Scalar (Record fields)) = Scalar . Record <$> traverse (go b) fields + go b (Scalar (TypeVar as u tn targs)) = + Scalar <$> (TypeVar as u tn <$> traverse (onTypeArg b) targs) + go b (Scalar (Sum cs)) = Scalar . Sum <$> traverse (traverse (go b)) cs + go _ (Scalar (Prim t)) = pure $ Scalar $ Prim t + go _ (Scalar (Arrow als p t1 t2)) = + Scalar <$> (Arrow als p <$> go PosParam t1 <*> go PosReturn t2) + + onTypeArg b (TypeArgDim d loc) = + TypeArgDim <$> f b d <*> pure loc + onTypeArg b (TypeArgType t loc) = + TypeArgType <$> go b t <*> pure loc + +mustBeExplicitAux :: StructType -> M.Map VName Bool +mustBeExplicitAux t = + execState (traverseDims onDim t) mempty + where onDim PosImmediate (NamedDim d) = + modify $ \s -> M.insertWith (&&) (qualLeaf d) False s + onDim _ (NamedDim d) = + modify $ M.insertWith (&&) (qualLeaf d) True + onDim _ _ = + return () + +-- | Figure out which of the sizes in a parameter type must be passed +-- explicitly, because their first use is as something else than just +-- an array dimension. 'mustBeExplicit' is like this function, but +-- first decomposes into parameter types. +mustBeExplicitInType :: StructType -> S.Set VName +mustBeExplicitInType t = + S.fromList $ M.keys $ M.filter id $ mustBeExplicitAux t + +-- | Figure out which of the sizes in a binding type must be passed +-- explicitly, because their first use is as something else than just +-- an array dimension. +mustBeExplicit :: StructType -> S.Set VName +mustBeExplicit bind_t = + let (ts, ret) = unfoldFunType bind_t + alsoRet = M.unionWith (&&) $ + M.fromList $ zip (S.toList $ typeDimNames ret) $ repeat True + in S.fromList $ M.keys $ M.filter id $ alsoRet $ foldl' onType mempty ts + where onType uses t = uses <> mustBeExplicitAux t -- Left-biased union. + +-- | Return the uniqueness of a type. +uniqueness :: TypeBase shape as -> Uniqueness +uniqueness (Array _ u _ _) = u +uniqueness (Scalar (TypeVar _ u _ _)) = u +uniqueness (Scalar (Sum ts)) = foldMap (foldMap uniqueness) $ M.elems ts +uniqueness (Scalar (Record fs)) = foldMap uniqueness $ M.elems fs +uniqueness _ = Nonunique + +-- | @unique t@ is 'True' if the type of the argument is unique. +unique :: TypeBase shape as -> Bool +unique = (==Unique) . uniqueness + +-- | Return the set of all variables mentioned in the aliasing of a +-- type. +aliases :: Monoid as => TypeBase shape as -> as +aliases = bifoldMap (const mempty) id + +-- | @diet t@ returns a description of how a function parameter of +-- type @t@ might consume its argument. +diet :: TypeBase shape as -> Diet +diet (Scalar (Record ets)) = RecordDiet $ fmap diet ets +diet (Scalar (Prim _)) = Observe +diet (Scalar (Arrow _ _ t1 t2)) = FuncDiet (diet t1) (diet t2) +diet (Array _ Unique _ _) = Consume +diet (Array _ Nonunique _ _) = Observe +diet (Scalar (TypeVar _ Unique _ _)) = Consume +diet (Scalar (TypeVar _ Nonunique _ _)) = Observe +diet (Scalar Sum{}) = Observe + +-- | Convert any type to one that has rank information, no alias +-- information, and no embedded names. +toStructural :: TypeBase dim as + -> TypeBase () () +toStructural = flip setAliases () . first (const ()) + +-- | Remove aliasing information from a type. +toStruct :: TypeBase dim as + -> TypeBase dim () +toStruct t = t `setAliases` () + +-- | Replace no aliasing with an empty alias set. +fromStruct :: TypeBase dim as + -> TypeBase dim Aliasing +fromStruct t = t `setAliases` S.empty + +-- | @peelArray n t@ returns the type resulting from peeling the first +-- @n@ array dimensions from @t@. Returns @Nothing@ if @t@ has less +-- than @n@ dimensions. +peelArray :: Int -> TypeBase dim as -> Maybe (TypeBase dim as) +peelArray n (Array als u t shape) + | shapeRank shape == n = + Just $ Scalar t `addAliases` const als + | otherwise = + Array als u t <$> stripDims n shape +peelArray _ _ = Nothing + +-- | @arrayOf t s u@ constructs an array type. The convenience +-- compared to using the 'Array' constructor directly is that @t@ can +-- itself be an array. If @t@ is an @n@-dimensional array, and @s@ is +-- a list of length @n@, the resulting type is of an @n+m@ dimensions. +-- The uniqueness of the new array will be @u@, no matter the +-- uniqueness of @t@. +arrayOf :: Monoid as => + TypeBase dim as + -> ShapeDecl dim + -> Uniqueness + -> TypeBase dim as +arrayOf t = arrayOfWithAliases (t `setUniqueness` Nonunique) mempty + +arrayOfWithAliases :: Monoid as => + TypeBase dim as + -> as + -> ShapeDecl dim + -> Uniqueness + -> TypeBase dim as +arrayOfWithAliases (Array as1 _ et shape1) as2 shape2 u = + Array (as1<>as2) u et (shape2 <> shape1) +arrayOfWithAliases (Scalar t) as shape u = + Array as u (second (const ()) t) shape + +-- | @stripArray n t@ removes the @n@ outermost layers of the array. +-- Essentially, it is the type of indexing an array of type @t@ with +-- @n@ indexes. +stripArray :: Int -> TypeBase dim as -> TypeBase dim as +stripArray n (Array als u et shape) + | Just shape' <- stripDims n shape = + Array als u et shape' + | otherwise = + Scalar et `setUniqueness` u `setAliases` als +stripArray _ t = t + +-- | Create a record type corresponding to a tuple with the given +-- element types. +tupleRecord :: [TypeBase dim as] -> TypeBase dim as +tupleRecord = Scalar . Record . M.fromList . zip tupleFieldNames + +-- | Does this type corespond to a tuple? If so, return the elements +-- of that tuple. +isTupleRecord :: TypeBase dim as -> Maybe [TypeBase dim as] +isTupleRecord (Scalar (Record fs)) = areTupleFields fs +isTupleRecord _ = Nothing + +-- | Does this record map correspond to a tuple? +areTupleFields :: M.Map Name a -> Maybe [a] +areTupleFields fs = + let fs' = sortFields fs + in if and $ zipWith (==) (map fst fs') tupleFieldNames + then Just $ map snd fs' + else Nothing + +-- | Construct a record map corresponding to a tuple. +tupleFields :: [a] -> M.Map Name a +tupleFields as = M.fromList $ zip tupleFieldNames as + +-- | Increasing field names for a tuple (starts at 0). +tupleFieldNames :: [Name] +tupleFieldNames = map (nameFromString . show) [(0::Int)..] + +-- | Sort fields by their name; taking care to sort numeric fields by +-- their numeric value. This ensures that tuples and tuple-like +-- records match. +sortFields :: M.Map Name a -> [(Name,a)] +sortFields l = map snd $ sortOn fst $ zip (map (fieldish . fst) l') l' + where l' = M.toList l + fieldish s = case reads $ nameToString s of + [(x, "")] -> Left (x::Int) + _ -> Right s + +-- | Sort the constructors of a sum type in some well-defined (but not +-- otherwise significant) manner. +sortConstrs :: M.Map Name a -> [(Name, a)] +sortConstrs cs = sortOn fst $ M.toList cs + +-- | Is this a 'TypeParamType'? +isTypeParam :: TypeParamBase vn -> Bool +isTypeParam TypeParamType{} = True +isTypeParam TypeParamDim{} = False + +-- | Is this a 'TypeParamDim'? +isSizeParam :: TypeParamBase vn -> Bool +isSizeParam = not . isTypeParam + +-- | Combine the shape information of types as much as possible. The first +-- argument is the orignal type and the second is the type of the transformed +-- expression. This is necessary since the original type may contain additional +-- information (e.g., shape restrictions) from the user given annotation. +combineTypeShapes :: (Monoid as, ArrayDim dim) => + TypeBase dim as -> TypeBase dim as -> TypeBase dim as +combineTypeShapes (Scalar (Record ts1)) (Scalar (Record ts2)) + | M.keys ts1 == M.keys ts2 = + Scalar $ Record $ M.map (uncurry combineTypeShapes) (M.intersectionWith (,) ts1 ts2) +combineTypeShapes (Scalar (Arrow als1 p1 a1 b1)) (Scalar (Arrow als2 _p2 a2 b2)) = + Scalar $ Arrow (als1<>als2) p1 (combineTypeShapes a1 a2) (combineTypeShapes b1 b2) +combineTypeShapes (Array als1 u1 et1 shape1) (Array als2 _u2 et2 _shape2) = + arrayOfWithAliases (combineTypeShapes (Scalar et1) (Scalar et2) + `setAliases` mempty) + (als1<>als2) shape1 u1 +combineTypeShapes _ new_tp = new_tp + +-- | Match the dimensions of otherwise assumed-equal types. +matchDims :: (Monoid as, Monad m) => + (d1 -> d2 -> m d1) + -> TypeBase d1 as -> TypeBase d2 as + -> m (TypeBase d1 as) +matchDims onDims t1 t2 = + case (t1, t2) of + (Array als1 u1 et1 shape1, Array als2 u2 et2 shape2) -> + flip setAliases (als1<>als2) <$> + (arrayOf <$> + matchDims onDims (Scalar et1) (Scalar et2) <*> + onShapes shape1 shape2 <*> pure (min u1 u2)) + (Scalar (Record f1), Scalar (Record f2)) -> + Scalar . Record <$> + traverse (uncurry (matchDims onDims)) (M.intersectionWith (,) f1 f2) + (Scalar (Sum cs1), Scalar (Sum cs2)) -> + Scalar . Sum <$> + traverse (traverse (uncurry (matchDims onDims))) + (M.intersectionWith zip cs1 cs2) + (Scalar (Arrow als1 p1 a1 b1), Scalar (Arrow als2 _p2 a2 b2)) -> + Scalar <$> + (Arrow (als1 <> als2) p1 <$> matchDims onDims a1 a2 <*> matchDims onDims b1 b2) + (Scalar (TypeVar als1 u v targs1), + Scalar (TypeVar als2 _ _ targs2)) -> + Scalar . TypeVar (als1 <> als2) u v <$> zipWithM matchTypeArg targs1 targs2 + _ -> return t1 + + where matchTypeArg ta@TypeArgType{} _ = return ta + matchTypeArg a _ = return a + + onShapes shape1 shape2 = + ShapeDecl <$> zipWithM onDims (shapeDims shape1) (shapeDims shape2) + + +-- | Set the uniqueness attribute of a type. If the type is a record +-- or sum type, the uniqueness of its components will be modified. +setUniqueness :: TypeBase dim as -> Uniqueness -> TypeBase dim as +setUniqueness (Array als _ et shape) u = + Array als u et shape +setUniqueness (Scalar (TypeVar als _ t targs)) u = + Scalar $ TypeVar als u t targs +setUniqueness (Scalar (Record ets)) u = + Scalar $ Record $ fmap (`setUniqueness` u) ets +setUniqueness (Scalar (Sum ets)) u = + Scalar $ Sum $ fmap (map (`setUniqueness` u)) ets +setUniqueness t _ = t + +-- | @t \`setAliases\` als@ returns @t@, but with @als@ substituted for +-- any already present aliasing. +setAliases :: TypeBase dim asf -> ast -> TypeBase dim ast +setAliases t = addAliases t . const + +-- | @t \`addAliases\` f@ returns @t@, but with any already present +-- aliasing replaced by @f@ applied to that aliasing. +addAliases :: TypeBase dim asf -> (asf -> ast) + -> TypeBase dim ast +addAliases = flip second + +intValueType :: IntValue -> IntType +intValueType Int8Value{} = Int8 +intValueType Int16Value{} = Int16 +intValueType Int32Value{} = Int32 +intValueType Int64Value{} = Int64 + +floatValueType :: FloatValue -> FloatType +floatValueType Float32Value{} = Float32 +floatValueType Float64Value{} = Float64 + +-- | The type of a basic value. +primValueType :: PrimValue -> PrimType +primValueType (SignedValue v) = Signed $ intValueType v +primValueType (UnsignedValue v) = Unsigned $ intValueType v +primValueType (FloatValue v) = FloatType $ floatValueType v +primValueType BoolValue{} = Bool + +-- | The type of the value. +valueType :: Value -> ValueType +valueType (PrimValue bv) = Scalar $ Prim $ primValueType bv +valueType (ArrayValue _ t) = t + +-- | The size of values of this type, in bytes. +primByteSize :: Num a => PrimType -> a +primByteSize (Signed it) = Primitive.intByteSize it +primByteSize (Unsigned it) = Primitive.intByteSize it +primByteSize (FloatType ft) = Primitive.floatByteSize ft +primByteSize Bool = 1 + +-- | Construct a 'ShapeDecl' with the given number of 'AnyDim' +-- dimensions. +rank :: Int -> ShapeDecl (DimDecl VName) +rank n = ShapeDecl $ replicate n AnyDim + +-- | The type is leaving a scope, so clean up any aliases that +-- reference the bound variables, and turn any dimensions that name +-- them into AnyDim instead. +unscopeType :: S.Set VName -> PatternType -> PatternType +unscopeType bound_here t = first onDim $ t `addAliases` S.map unbind + where unbind (AliasBound v) | v `S.member` bound_here = AliasFree v + unbind a = a + onDim (NamedDim qn) | qualLeaf qn `S.member` bound_here = AnyDim + onDim d = d + +-- | Perform some operation on a given record field. Returns +-- 'Nothing' if that field does not exist. +onRecordField :: (TypeBase dim als -> TypeBase dim als) + -> [Name] + -> TypeBase dim als -> Maybe (TypeBase dim als) +onRecordField f [] t = Just $ f t +onRecordField f (k:ks) (Scalar (Record m)) = do + t <- onRecordField f ks =<< M.lookup k m + Just $ Scalar $ Record $ M.insert k t m +onRecordField _ _ _ = Nothing + +-- | The type of an Futhark term. The aliasing will refer to itself, if +-- the term is a non-tuple-typed variable. +typeOf :: ExpBase Info VName -> PatternType +typeOf (Literal val _) = Scalar $ Prim $ primValueType val +typeOf (IntLit _ (Info t) _) = t +typeOf (FloatLit _ (Info t) _) = t +typeOf (Parens e _) = typeOf e +typeOf (QualParens _ e _) = typeOf e +typeOf (TupLit es _) = tupleRecord $ map typeOf es +typeOf (RecordLit fs _) = + -- Reverse, because M.unions is biased to the left. + Scalar $ Record $ M.unions $ reverse $ map record fs + where record (RecordFieldExplicit name e _) = M.singleton name $ typeOf e + record (RecordFieldImplicit name (Info t) _) = + M.singleton (baseName name) $ t + `addAliases` S.insert (AliasBound name) +typeOf (ArrayLit _ (Info t) _) = t +typeOf (StringLit vs _) = + Array mempty Unique (Prim (Unsigned Int8)) + (ShapeDecl [ConstDim $ genericLength vs]) +typeOf (Range _ _ _ (Info t, _) _) = t +typeOf (BinOp _ _ _ _ (Info t) _ _) = t +typeOf (Project _ _ (Info t) _) = t +typeOf (If _ _ _ (Info t, _) _) = t +typeOf (Var _ (Info t) _) = t +typeOf (Ascript e _ _) = typeOf e +typeOf (Coerce _ _ (Info t, _) _) = t +typeOf (Apply _ _ _ (Info t, _) _) = t +typeOf (Negate e _) = typeOf e +typeOf (LetPat _ _ _ (Info t, _) _) = t +typeOf (LetFun _ _ _ (Info t) _) = t +typeOf (LetWith _ _ _ _ _ (Info t) _) = t +typeOf (Index _ _ (Info t, _) _) = t +typeOf (Update e _ _ _) = typeOf e `setAliases` mempty +typeOf (RecordUpdate _ _ _ (Info t) _) = t +typeOf (Unsafe e _) = typeOf e +typeOf (Assert _ e _ _) = typeOf e +typeOf (DoLoop _ _ _ _ _ (Info (t, _)) _) = t +typeOf (Lambda params _ _ (Info (als, t)) _) = + unscopeType bound_here $ foldr (arrow . patternParam) t params `setAliases` als + where bound_here = S.map identName (mconcat $ map patternIdents params) `S.difference` + S.fromList (mapMaybe (named . patternParam) params) + arrow (px, tx) y = Scalar $ Arrow () px tx y + named (Named x, _) = Just x + named (Unnamed, _) = Nothing +typeOf (OpSection _ (Info t) _) = + t +typeOf (OpSectionLeft _ _ _ (_, Info pt2) (Info ret, _) _) = + foldFunType [fromStruct pt2] ret +typeOf (OpSectionRight _ _ _ (Info pt1, _) (Info ret) _) = + foldFunType [fromStruct pt1] ret +typeOf (ProjectSection _ (Info t) _) = t +typeOf (IndexSection _ (Info t) _) = t +typeOf (Constr _ _ (Info t) _) = t +typeOf (Match _ cs (Info t, _) _) = + unscopeType (foldMap unscopeSet cs) t + where unscopeSet (CasePat p _ _) = S.map identName $ patternIdents p +typeOf (Attr _ e _) = typeOf e + +-- | @foldFunType ts ret@ creates a function type ('Arrow') that takes +-- @ts@ as parameters and returns @ret@. +foldFunType :: Monoid as => [TypeBase dim as] -> TypeBase dim as -> TypeBase dim as +foldFunType ps ret = foldr arrow ret ps + where arrow t1 t2 = Scalar $ Arrow mempty Unnamed t1 t2 + +-- | Extract the parameter types and return type from a type. +-- If the type is not an arrow type, the list of parameter types is empty. +unfoldFunType :: TypeBase dim as -> ([TypeBase dim as], TypeBase dim as) +unfoldFunType (Scalar (Arrow _ _ t1 t2)) = + let (ps, r) = unfoldFunType t2 + in (t1 : ps, r) +unfoldFunType t = ([], t) + +-- | The type names mentioned in a type. +typeVars :: Monoid as => TypeBase dim as -> S.Set VName +typeVars t = + case t of + Scalar Prim{} -> mempty + Scalar (TypeVar _ _ tn targs) -> + mconcat $ typeVarFree tn : map typeArgFree targs + Scalar (Arrow _ _ t1 t2) -> typeVars t1 <> typeVars t2 + Scalar (Record fields) -> foldMap typeVars fields + Scalar (Sum cs) -> mconcat $ (foldMap . fmap) typeVars cs + Array _ _ rt _ -> typeVars $ Scalar rt + where typeVarFree = S.singleton . typeLeaf + typeArgFree (TypeArgType ta _) = typeVars ta + typeArgFree TypeArgDim{} = mempty + +-- | @orderZero t@ is 'True' if the argument type has order 0, i.e., it is not +-- a function type, does not contain a function type as a subcomponent, and may +-- not be instantiated with a function type. +orderZero :: TypeBase dim as -> Bool +orderZero Array{} = True +orderZero (Scalar (Prim _)) = True +orderZero (Scalar (Record fs)) = all orderZero $ M.elems fs +orderZero (Scalar TypeVar{}) = True +orderZero (Scalar Arrow{}) = False +orderZero (Scalar (Sum cs)) = all (all orderZero) cs + +-- | Extract all the shape names that occur in a given pattern. +patternDimNames :: PatternBase Info VName -> S.Set VName +patternDimNames (TuplePattern ps _) = foldMap patternDimNames ps +patternDimNames (RecordPattern fs _) = foldMap (patternDimNames . snd) fs +patternDimNames (PatternParens p _) = patternDimNames p +patternDimNames (Id _ (Info tp) _) = typeDimNames tp +patternDimNames (Wildcard (Info tp) _) = typeDimNames tp +patternDimNames (PatternAscription p (TypeDecl _ (Info t)) _) = + patternDimNames p <> typeDimNames t +patternDimNames (PatternLit _ (Info tp) _) = typeDimNames tp +patternDimNames (PatternConstr _ _ ps _) = foldMap patternDimNames ps + +-- | Extract all the shape names that occur in a given type. +typeDimNames :: TypeBase (DimDecl VName) als -> S.Set VName +typeDimNames = foldMap dimName . nestedDims + where dimName :: DimDecl VName -> S.Set VName + dimName (NamedDim qn) = S.singleton $ qualLeaf qn + dimName _ = mempty + +-- | @patternOrderZero pat@ is 'True' if all of the types in the given pattern +-- have order 0. +patternOrderZero :: PatternBase Info vn -> Bool +patternOrderZero pat = case pat of + TuplePattern ps _ -> all patternOrderZero ps + RecordPattern fs _ -> all (patternOrderZero . snd) fs + PatternParens p _ -> patternOrderZero p + Id _ (Info t) _ -> orderZero t + Wildcard (Info t) _ -> orderZero t + PatternAscription p _ _ -> patternOrderZero p + PatternLit _ (Info t) _ -> orderZero t + PatternConstr _ _ ps _ -> all patternOrderZero ps + +-- | The set of identifiers bound in a pattern. +patternIdents :: (Functor f, Ord vn) => PatternBase f vn -> S.Set (IdentBase f vn) +patternIdents (Id v t loc) = S.singleton $ Ident v t loc +patternIdents (PatternParens p _) = patternIdents p +patternIdents (TuplePattern pats _) = mconcat $ map patternIdents pats +patternIdents (RecordPattern fs _) = mconcat $ map (patternIdents . snd) fs +patternIdents Wildcard{} = mempty +patternIdents (PatternAscription p _ _) = patternIdents p +patternIdents PatternLit{} = mempty +patternIdents (PatternConstr _ _ ps _ ) = mconcat $ map patternIdents ps + +-- | The set of names bound in a pattern. +patternNames :: (Functor f, Ord vn) => PatternBase f vn -> S.Set vn +patternNames (Id v _ _) = S.singleton v +patternNames (PatternParens p _) = patternNames p +patternNames (TuplePattern pats _) = mconcat $ map patternNames pats +patternNames (RecordPattern fs _) = mconcat $ map (patternNames . snd) fs +patternNames Wildcard{} = mempty +patternNames (PatternAscription p _ _) = patternNames p +patternNames PatternLit{} = mempty +patternNames (PatternConstr _ _ ps _ ) = mconcat $ map patternNames ps + +-- | A mapping from names bound in a map to their identifier. +patternMap :: (Functor f) => PatternBase f VName -> M.Map VName (IdentBase f VName) +patternMap pat = + M.fromList $ zip (map identName idents) idents + where idents = S.toList $ patternIdents pat + +-- | The type of values bound by the pattern. +patternType :: PatternBase Info VName -> PatternType +patternType (Wildcard (Info t) _) = t +patternType (PatternParens p _) = patternType p +patternType (Id _ (Info t) _) = t +patternType (TuplePattern pats _) = tupleRecord $ map patternType pats +patternType (RecordPattern fs _) = Scalar $ Record $ patternType <$> M.fromList fs +patternType (PatternAscription p _ _) = patternType p +patternType (PatternLit _ (Info t) _) = t +patternType (PatternConstr _ (Info t) _ _) = t + +-- | The type matched by the pattern, including shape declarations if present. +patternStructType :: PatternBase Info VName -> StructType +patternStructType = toStruct . patternType + +-- | When viewed as a function parameter, does this pattern correspond +-- to a named parameter of some type? +patternParam :: PatternBase Info VName -> (PName, StructType) +patternParam (PatternParens p _) = + patternParam p +patternParam (PatternAscription (Id v _ _) td _) = + (Named v, unInfo $ expandedType td) +patternParam (Id v (Info t) _) = + (Named v, toStruct t) +patternParam p = + (Unnamed, patternStructType p) + +-- | Names of primitive types to types. This is only valid if no +-- shadowing is going on, but useful for tools. +namesToPrimTypes :: M.Map Name PrimType +namesToPrimTypes = M.fromList + [ (nameFromString $ pretty t, t) | + t <- Bool : + map Signed [minBound..maxBound] ++ + map Unsigned [minBound..maxBound] ++ + map FloatType [minBound..maxBound] ] + +-- | The nature of something predefined. These can either be +-- monomorphic or overloaded. An overloaded builtin is a list valid +-- types it can be instantiated with, to the parameter and result +-- type, with 'Nothing' representing the overloaded parameter type. +data Intrinsic = IntrinsicMonoFun [PrimType] PrimType + | IntrinsicOverloadedFun [PrimType] [Maybe PrimType] (Maybe PrimType) + | IntrinsicPolyFun [TypeParamBase VName] [StructType] StructType + | IntrinsicType PrimType + | IntrinsicEquality -- Special cased. + +-- | A map of all built-ins. +intrinsics :: M.Map VName Intrinsic +intrinsics = M.fromList $ zipWith namify [10..] $ + + map primFun (M.toList Primitive.primFuns) ++ + + [("opaque", IntrinsicPolyFun [tp_a] [Scalar t_a] $ Scalar t_a)] ++ + + map unOpFun Primitive.allUnOps ++ + + map binOpFun Primitive.allBinOps ++ + + map cmpOpFun Primitive.allCmpOps ++ + + map convOpFun Primitive.allConvOps ++ + + map signFun Primitive.allIntTypes ++ + + map unsignFun Primitive.allIntTypes ++ + + map intrinsicType (map Signed [minBound..maxBound] ++ + map Unsigned [minBound..maxBound] ++ + map FloatType [minBound..maxBound] ++ + [Bool]) ++ + + -- This overrides the ! from Primitive. + [ ("!", IntrinsicOverloadedFun + (map Signed [minBound..maxBound] ++ + map Unsigned [minBound..maxBound] ++ + [Bool]) + [Nothing] Nothing) ] ++ + + -- The reason for the loop formulation is to ensure that we + -- get a missing case warning if we forget a case. + mapMaybe mkIntrinsicBinOp [minBound..maxBound] ++ + + [("flatten", IntrinsicPolyFun [tp_a] + [Array () Nonunique t_a (rank 2)] $ + Array () Nonunique t_a (rank 1)), + ("unflatten", IntrinsicPolyFun [tp_a] + [Scalar $ Prim $ Signed Int32, + Scalar $ Prim $ Signed Int32, + Array () Nonunique t_a (rank 1)] $ + Array () Nonunique t_a (rank 2)), + + ("concat", IntrinsicPolyFun [tp_a] + [arr_a, arr_a] uarr_a), + ("rotate", IntrinsicPolyFun [tp_a] + [Scalar $ Prim $ Signed Int32, arr_a] arr_a), + ("transpose", IntrinsicPolyFun [tp_a] [arr_2d_a] arr_2d_a), + + ("scatter", IntrinsicPolyFun [tp_a] + [Array () Unique t_a (rank 1), + Array () Nonunique (Prim $ Signed Int32) (rank 1), + Array () Nonunique t_a (rank 1)] $ + Array () Unique t_a (rank 1)), + + ("zip", IntrinsicPolyFun [tp_a, tp_b] [arr_a, arr_b] arr_a_b), + ("unzip", IntrinsicPolyFun [tp_a, tp_b] [arr_a_b] t_arr_a_arr_b), + + ("hist", IntrinsicPolyFun [tp_a] + [Scalar $ Prim $ Signed Int32, + uarr_a, + Scalar t_a `arr` (Scalar t_a `arr` Scalar t_a), + Scalar t_a, + Array () Nonunique (Prim $ Signed Int32) (rank 1), + arr_a] + uarr_a), + + ("map", IntrinsicPolyFun [tp_a, tp_b] [Scalar t_a `arr` Scalar t_b, arr_a] uarr_b), + + ("reduce", IntrinsicPolyFun [tp_a] + [Scalar t_a `arr` (Scalar t_a `arr` Scalar t_a), Scalar t_a, arr_a] $ + Scalar t_a), + + ("reduce_comm", IntrinsicPolyFun [tp_a] + [Scalar t_a `arr` (Scalar t_a `arr` Scalar t_a), Scalar t_a, arr_a] $ + Scalar t_a), + + ("scan", IntrinsicPolyFun [tp_a] + [Scalar t_a `arr` (Scalar t_a `arr` Scalar t_a), Scalar t_a, arr_a] uarr_a), + + ("partition", + IntrinsicPolyFun [tp_a] + [Scalar (Prim $ Signed Int32), + Scalar t_a `arr` Scalar (Prim $ Signed Int32), arr_a] $ + tupleRecord [uarr_a, Array () Unique (Prim $ Signed Int32) (rank 1)]), + + ("map_stream", + IntrinsicPolyFun [tp_a, tp_b] + [Scalar (Prim $ Signed Int32) `karr` (arr_ka `arr` arr_kb), arr_a] + uarr_b), + + ("map_stream_per", + IntrinsicPolyFun [tp_a, tp_b] + [Scalar (Prim $ Signed Int32) `karr` (arr_ka `arr` arr_kb), arr_a] + uarr_b), + + ("reduce_stream", + IntrinsicPolyFun [tp_a, tp_b] + [Scalar t_b `arr` (Scalar t_b `arr` Scalar t_b), + Scalar (Prim $ Signed Int32) `karr` (arr_ka `arr` Scalar t_b), + arr_a] $ + Scalar t_b), + + ("reduce_stream_per", + IntrinsicPolyFun [tp_a, tp_b] + [Scalar t_b `arr` (Scalar t_b `arr` Scalar t_b), + Scalar (Prim $ Signed Int32) `karr` (arr_ka `arr` Scalar t_b), + arr_a] $ + Scalar t_b), + + ("trace", IntrinsicPolyFun [tp_a] [Scalar t_a] $ Scalar t_a), + ("break", IntrinsicPolyFun [tp_a] [Scalar t_a] $ Scalar t_a)] + + where tv_a = VName (nameFromString "a") 0 + t_a = TypeVar () Nonunique (typeName tv_a) [] + arr_a = Array () Nonunique t_a (rank 1) + arr_2d_a = Array () Nonunique t_a (rank 2) + uarr_a = Array () Unique t_a (rank 1) + tp_a = TypeParamType Unlifted tv_a mempty + + tv_b = VName (nameFromString "b") 1 + t_b = TypeVar () Nonunique (typeName tv_b) [] + arr_b = Array () Nonunique t_b (rank 1) + uarr_b = Array () Unique t_b (rank 1) + tp_b = TypeParamType Unlifted tv_b mempty + + arr_a_b = Array () Nonunique + (Record (M.fromList $ zip tupleFieldNames [Scalar t_a, Scalar t_b])) + (rank 1) + t_arr_a_arr_b = Scalar $ Record $ M.fromList $ zip tupleFieldNames [arr_a, arr_b] + + arr x y = Scalar $ Arrow mempty Unnamed x y + + kv = VName (nameFromString "k") 2 + arr_ka = Array () Nonunique t_a (ShapeDecl [NamedDim $ qualName kv]) + arr_kb = Array () Nonunique t_b (ShapeDecl [NamedDim $ qualName kv]) + karr x y = Scalar $ Arrow mempty (Named kv) x y + + namify i (k,v) = (VName (nameFromString k) i, v) + + primFun (name, (ts,t, _)) = + (name, IntrinsicMonoFun (map unPrim ts) $ unPrim t) + + unOpFun bop = (pretty bop, IntrinsicMonoFun [t] t) + where t = unPrim $ Primitive.unOpType bop + + binOpFun bop = (pretty bop, IntrinsicMonoFun [t, t] t) + where t = unPrim $ Primitive.binOpType bop + + cmpOpFun bop = (pretty bop, IntrinsicMonoFun [t, t] Bool) + where t = unPrim $ Primitive.cmpOpType bop + + convOpFun cop = (pretty cop, IntrinsicMonoFun [unPrim ft] $ unPrim tt) + where (ft, tt) = Primitive.convOpType cop + + signFun t = ("sign_" ++ pretty t, IntrinsicMonoFun [Unsigned t] $ Signed t) + + unsignFun t = ("unsign_" ++ pretty t, IntrinsicMonoFun [Signed t] $ Unsigned t) + + unPrim (Primitive.IntType t) = Signed t + unPrim (Primitive.FloatType t) = FloatType t + unPrim Primitive.Bool = Bool + unPrim Primitive.Cert = Bool + + intrinsicType t = (pretty t, IntrinsicType t) + + anyIntType = map Signed [minBound..maxBound] ++ + map Unsigned [minBound..maxBound] + anyNumberType = anyIntType ++ + map FloatType [minBound..maxBound] + anyPrimType = Bool : anyNumberType + + mkIntrinsicBinOp :: BinOp -> Maybe (String, Intrinsic) + mkIntrinsicBinOp op = do op' <- intrinsicBinOp op + return (pretty op, op') + + binOp ts = Just $ IntrinsicOverloadedFun ts [Nothing, Nothing] Nothing + ordering = Just $ IntrinsicOverloadedFun anyPrimType [Nothing, Nothing] (Just Bool) + + intrinsicBinOp Plus = binOp anyNumberType + intrinsicBinOp Minus = binOp anyNumberType + intrinsicBinOp Pow = binOp anyNumberType + intrinsicBinOp Times = binOp anyNumberType + intrinsicBinOp Divide = binOp anyNumberType + intrinsicBinOp Mod = binOp anyNumberType + intrinsicBinOp Quot = binOp anyIntType + intrinsicBinOp Rem = binOp anyIntType + intrinsicBinOp ShiftR = binOp anyIntType + intrinsicBinOp ShiftL = binOp anyIntType + intrinsicBinOp Band = binOp anyIntType + intrinsicBinOp Xor = binOp anyIntType + intrinsicBinOp Bor = binOp anyIntType + intrinsicBinOp LogAnd = binOp [Bool] + intrinsicBinOp LogOr = binOp [Bool] + intrinsicBinOp Equal = Just IntrinsicEquality + intrinsicBinOp NotEqual = Just IntrinsicEquality + intrinsicBinOp Less = ordering + intrinsicBinOp Leq = ordering + intrinsicBinOp Greater = ordering + intrinsicBinOp Geq = ordering + intrinsicBinOp _ = Nothing + +-- | The largest tag used by an intrinsic - this can be used to +-- determine whether a 'VName' refers to an intrinsic or a user-defined name. +maxIntrinsicTag :: Int +maxIntrinsicTag = maximum $ map baseTag $ M.keys intrinsics + +-- | Create a name with no qualifiers from a name. +qualName :: v -> QualName v +qualName = QualName [] + +-- | Add another qualifier (at the head) to a qualified name. +qualify :: v -> QualName v -> QualName v +qualify k (QualName ks v) = QualName (k:ks) v + +-- | Create a type name name with no qualifiers from a 'VName'. +typeName :: VName -> TypeName +typeName = typeNameFromQualName . qualName + +-- | The modules imported by a Futhark program. +progImports :: ProgBase f vn -> [(String,SrcLoc)] +progImports = concatMap decImports . progDecs + +-- | The modules imported by a single declaration. +decImports :: DecBase f vn -> [(String,SrcLoc)] +decImports (OpenDec x _) = modExpImports x +decImports (ModDec md) = modExpImports $ modExp md +decImports SigDec{} = [] +decImports TypeDec{} = [] +decImports ValDec{} = [] +decImports (LocalDec d _) = decImports d +decImports (ImportDec x _ loc) = [(x, loc)] + +modExpImports :: ModExpBase f vn -> [(String,SrcLoc)] +modExpImports ModVar{} = [] +modExpImports (ModParens p _) = modExpImports p +modExpImports (ModImport f _ loc) = [(f,loc)] +modExpImports (ModDecs ds _) = concatMap decImports ds +modExpImports (ModApply _ me _ _ _) = modExpImports me +modExpImports (ModAscript me _ _ _) = modExpImports me +modExpImports ModLambda{} = [] + +-- | The set of module types used in any exported (non-local) +-- declaration. +progModuleTypes :: Ord vn => ProgBase f vn -> S.Set vn +progModuleTypes = mconcat . map onDec . progDecs + where onDec (OpenDec x _) = onModExp x + onDec (ModDec md) = + maybe mempty (onSigExp . fst) (modSignature md) <> onModExp (modExp md) + onDec SigDec{} = mempty + onDec TypeDec{} = mempty + onDec ValDec{} = mempty + onDec LocalDec{} = mempty + onDec ImportDec{} = mempty + + onModExp ModVar{} = mempty + onModExp (ModParens p _) = onModExp p + onModExp ModImport {} = mempty + onModExp (ModDecs ds _) = mconcat $ map onDec ds + onModExp (ModApply me1 me2 _ _ _) = onModExp me1 <> onModExp me2 + onModExp (ModAscript me se _ _) = onModExp me <> onSigExp se + onModExp (ModLambda p r me _) = + onModParam p <> maybe mempty (onSigExp . fst) r <> onModExp me + + onModParam = onSigExp . modParamType + + onSigExp (SigVar v _ _) = S.singleton $ qualLeaf v + onSigExp (SigParens e _) = onSigExp e + onSigExp SigSpecs{} = mempty + onSigExp (SigWith e _ _) = onSigExp e + onSigExp (SigArrow _ e1 e2 _) = onSigExp e1 <> onSigExp e2 + +-- | Extract a leading @((name, namespace, file), remainder)@ from a +-- documentation comment string. These are formatted as +-- \`name\`\@namespace[\@file]. Let us hope that this pattern does not occur +-- anywhere else. +identifierReference :: String -> Maybe ((String, String, Maybe FilePath), String) +identifierReference ('`' : s) + | (identifier, '`' : '@' : s') <- break (=='`') s, + (namespace, s'') <- span isAlpha s', + not $ null namespace = + case s'' of + '@' : '"' : s''' + | (file, '"' : s'''') <- span (/= '"') s''' -> + Just ((identifier, namespace, Just file), s'''') + _ -> Just ((identifier, namespace, Nothing), s'') + +identifierReference _ = Nothing + +-- | Given an operator name, return the operator that determines its +-- syntactical properties. +leadingOperator :: Name -> BinOp +leadingOperator s = maybe Backtick snd $ find ((`isPrefixOf` s') . fst) $ + sortOn (Down . length . fst) $ + zip (map pretty operators) operators + where s' = nameToString s + operators :: [BinOp] + operators = [minBound..maxBound::BinOp] + +-- | A type with no aliasing information but shape annotations. +type UncheckedType = TypeBase (ShapeDecl Name) () + +-- | An expression with no type annotations. +type UncheckedTypeExp = TypeExp Name + +-- | A type declaration with no expanded type. +type UncheckedTypeDecl = TypeDeclBase NoInfo Name + +-- | An identifier with no type annotations. +type UncheckedIdent = IdentBase NoInfo Name + +-- | An index with no type annotations. +type UncheckedDimIndex = DimIndexBase NoInfo Name + +-- | An expression with no type annotations. +type UncheckedExp = ExpBase NoInfo Name + +-- | A module expression with no type annotations. +type UncheckedModExp = ModExpBase NoInfo Name + +-- | A module type expression with no type annotations. +type UncheckedSigExp = SigExpBase NoInfo Name + +-- | A type parameter with no type annotations. +type UncheckedTypeParam = TypeParamBase Name + +-- | A pattern with no type annotations. +type UncheckedPattern = PatternBase NoInfo Name + +-- | A function declaration with no type annotations. +type UncheckedValBind = ValBindBase NoInfo Name + +-- | A declaration with no type annotations. +type UncheckedDec = DecBase NoInfo Name + +-- | A Futhark program with no type annotations. +type UncheckedProg = ProgBase NoInfo Name + +-- | A case (of a match expression) with no type annotations. +type UncheckedCase = CaseBase NoInfo Name diff --git a/src/Language/Futhark/Query.hs b/src/Language/Futhark/Query.hs --- a/src/Language/Futhark/Query.hs +++ b/src/Language/Futhark/Query.hs @@ -6,7 +6,6 @@ module Language.Futhark.Query ( BoundTo(..) , boundLoc - , allBindings , AtPos(..) , atPos , Pos(..) @@ -16,10 +15,10 @@ import Control.Monad import Control.Monad.State import Data.List (find) -import Data.Loc (Pos(..), Located(..), Loc(..)) import qualified Data.Map as M import qualified System.FilePath.Posix as Posix +import Futhark.Util.Loc (Pos(..), Loc(..)) import Language.Futhark import Language.Futhark.Semantic import Language.Futhark.Traversals diff --git a/src/Language/Futhark/Semantic.hs b/src/Language/Futhark/Semantic.hs --- a/src/Language/Futhark/Semantic.hs +++ b/src/Language/Futhark/Semantic.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE Safe #-} -- | Definitions of various semantic objects (*not* the Futhark -- semantics themselves). module Language.Futhark.Semantic @@ -22,7 +23,6 @@ ) where -import Data.Loc import qualified Data.Map.Strict as M import qualified System.FilePath.Posix as Posix import qualified System.FilePath as Native @@ -32,6 +32,7 @@ import Language.Futhark import Futhark.Util (dropLast, toPOSIX, fromPOSIX) import Futhark.Util.Pretty +import Futhark.Util.Loc -- | Canonical reference to a Futhark code file. Does not include the -- @.fut@ extension. This is most often a path relative to the @@ -122,6 +123,8 @@ data BoundV = BoundV [TypeParam] StructType deriving (Show) +-- | A mapping from names (which always exist in some namespace) to a +-- unique (tagged) name. type NameMap = M.Map (Namespace, Name) (QualName VName) -- | Modules produces environment with this representation. diff --git a/src/Language/Futhark/Syntax.hs b/src/Language/Futhark/Syntax.hs --- a/src/Language/Futhark/Syntax.hs +++ b/src/Language/Futhark/Syntax.hs @@ -1,14 +1,13 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Safe #-} {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE StrictData #-} {-# LANGUAGE Strict #-} --- | This is an ever-changing syntax representation for Futhark. Some --- types, such as @Exp@, are parametrised by type and name --- representation. See the @https://futhark.readthedocs.org@ for a --- language reference, or this module may be a little hard to --- understand. +-- | The Futhark source language AST definition. Many types, such as +-- 'ExpBase'@, are parametrised by type and name representation. See +-- the @https://futhark.readthedocs.org@ for a language reference, or +-- this module may be a little hard to understand. module Language.Futhark.Syntax ( module Language.Futhark.Core @@ -48,6 +47,7 @@ , Value(..) -- * Abstract syntax tree + , AttrInfo(..) , BinOp (..) , IdentBase (..) , Inclusiveness(..) @@ -96,7 +96,6 @@ import Data.Bifunctor import Data.Bitraversable import Data.Foldable -import Data.Loc import qualified Data.Map.Strict as M import Data.Monoid hiding (Sum) import Data.Ord @@ -105,10 +104,11 @@ import qualified Data.List.NonEmpty as NE import Prelude -import Futhark.Representation.Primitive (FloatType (..), +import Futhark.IR.Primitive (FloatType (..), FloatValue (..), IntType (..), IntValue (..)) import Futhark.Util.Pretty +import Futhark.Util.Loc import Language.Futhark.Core -- | Convenience class for deriving 'Show' instances for the AST. @@ -168,6 +168,8 @@ | BoolValue !Bool deriving (Eq, Ord, Show) +-- | A class for converting ordinary Haskell values to primitive +-- Futhark values. class IsPrimValue v where primValue :: v -> PrimValue @@ -201,6 +203,11 @@ instance IsPrimValue Bool where primValue = BoolValue +-- | The payload of an attribute. +newtype AttrInfo = AttrInfo Name + deriving (Eq, Ord, Show) + +-- | A type class for things that can be array dimensions. class Eq dim => ArrayDim dim where -- | @unifyDims x y@ combines @x@ and @y@ to contain their maximum -- common information, and fails if they conflict. @@ -295,9 +302,11 @@ instance Ord TypeName where TypeName _ x `compare` TypeName _ y = x `compare` y +-- | Convert a 'QualName' to a 'TypeName'. typeNameFromQualName :: QualName VName -> TypeName typeNameFromQualName (QualName qs x) = TypeName qs x +-- | Convert a 'TypeName' to a 'QualName'. qualNameFromTypeName :: TypeName -> QualName VName qualNameFromTypeName (TypeName qs x) = QualName qs x @@ -361,6 +370,7 @@ instance Bifoldable TypeBase where bifoldMap = bifoldMapDefault +-- | An argument passed to a type constructor. data TypeArg dim = TypeArgDim dim SrcLoc | TypeArgType (TypeBase dim ()) SrcLoc deriving (Eq, Ord, Show) @@ -414,6 +424,7 @@ -- | An unstructured type with type variables and possibly shape -- declarations - this is what the user types in the source program. +-- These are used to construct 'TypeBase's in the type checker. data TypeExp vn = TEVar (QualName vn) SrcLoc | TETuple [TypeExp vn] SrcLoc | TERecord [(Name, TypeExp vn)] SrcLoc @@ -438,6 +449,7 @@ locOf (TEArrow _ _ _ loc) = locOf loc locOf (TESum _ loc) = locOf loc +-- | A type argument expression passed to a type constructor. data TypeArgExp vn = TypeArgExpDim (DimExp vn) SrcLoc | TypeArgExpType (TypeExp vn) deriving (Show) @@ -725,6 +737,10 @@ | Match (ExpBase f vn) (NE.NonEmpty (CaseBase f vn)) (f PatternType, f [VName]) SrcLoc -- ^ A match expression. + + | Attr AttrInfo (ExpBase f vn) SrcLoc + -- ^ An attribute applied to the following expression. + deriving instance Showable f vn => Show (ExpBase f vn) deriving instance Eq (ExpBase NoInfo VName) deriving instance Ord (ExpBase NoInfo VName) @@ -765,6 +781,7 @@ locOf (Assert _ _ _ loc) = locOf loc locOf (Constr _ _ _ loc) = locOf loc locOf (Match _ _ _ loc) = locOf loc + locOf (Attr _ _ loc) = locOf loc -- | An entry in a record literal. data FieldBase f vn = RecordFieldExplicit Name (ExpBase f vn) SrcLoc @@ -891,10 +908,12 @@ -- ^ May be instantiated with a functional type. deriving (Eq, Ord, Show) -data TypeParamBase vn = TypeParamDim vn SrcLoc - -- ^ A type parameter that must be a size. - | TypeParamType Liftedness vn SrcLoc - -- ^ A type parameter that must be a type. +-- | A type parameter. +data TypeParamBase vn + = TypeParamDim vn SrcLoc + -- ^ A type parameter that must be a size. + | TypeParamType Liftedness vn SrcLoc + -- ^ A type parameter that must be a type. deriving (Eq, Ord, Show) instance Functor TypeParamBase where @@ -911,20 +930,24 @@ locOf (TypeParamDim _ loc) = locOf loc locOf (TypeParamType _ _ loc) = locOf loc +-- | The name of a type parameter. typeParamName :: TypeParamBase vn -> vn typeParamName (TypeParamDim v _) = v typeParamName (TypeParamType _ v _) = v -data SpecBase f vn = ValSpec { specName :: vn - , specTypeParams :: [TypeParamBase vn] - , specType :: TypeDeclBase f vn - , specDoc :: Maybe DocComment - , specLocation :: SrcLoc - } - | TypeAbbrSpec (TypeBindBase f vn) - | TypeSpec Liftedness vn [TypeParamBase vn] (Maybe DocComment) SrcLoc -- ^ Abstract type. - | ModSpec vn (SigExpBase f vn) (Maybe DocComment) SrcLoc - | IncludeSpec (SigExpBase f vn) SrcLoc +-- | A spec is a component of a module type. +data SpecBase f vn + = ValSpec { specName :: vn + , specTypeParams :: [TypeParamBase vn] + , specType :: TypeDeclBase f vn + , specDoc :: Maybe DocComment + , specLocation :: SrcLoc + } + | TypeAbbrSpec (TypeBindBase f vn) + | TypeSpec Liftedness vn [TypeParamBase vn] (Maybe DocComment) SrcLoc + -- ^ Abstract type. + | ModSpec vn (SigExpBase f vn) (Maybe DocComment) SrcLoc + | IncludeSpec (SigExpBase f vn) SrcLoc deriving instance Showable f vn => Show (SpecBase f vn) instance Located (SpecBase f vn) where @@ -934,11 +957,13 @@ locOf (ModSpec _ _ _ loc) = locOf loc locOf (IncludeSpec _ loc) = locOf loc -data SigExpBase f vn = SigVar (QualName vn) (f (M.Map VName VName)) SrcLoc - | SigParens (SigExpBase f vn) SrcLoc - | SigSpecs [SpecBase f vn] SrcLoc - | SigWith (SigExpBase f vn) (TypeRefBase f vn) SrcLoc - | SigArrow (Maybe vn) (SigExpBase f vn) (SigExpBase f vn) SrcLoc +-- | A module type expression. +data SigExpBase f vn + = SigVar (QualName vn) (f (M.Map VName VName)) SrcLoc + | SigParens (SigExpBase f vn) SrcLoc + | SigSpecs [SpecBase f vn] SrcLoc + | SigWith (SigExpBase f vn) (TypeRefBase f vn) SrcLoc + | SigArrow (Maybe vn) (SigExpBase f vn) (SigExpBase f vn) SrcLoc deriving instance Showable f vn => Show (SigExpBase f vn) -- | A type refinement. @@ -955,6 +980,7 @@ locOf (SigWith _ _ loc) = locOf loc locOf (SigArrow _ _ _ loc) = locOf loc +-- | Module type binding. data SigBindBase f vn = SigBind { sigName :: vn , sigExp :: SigExpBase f vn , sigDoc :: Maybe DocComment @@ -965,18 +991,20 @@ instance Located (SigBindBase f vn) where locOf = locOf . sigLoc -data ModExpBase f vn = ModVar (QualName vn) SrcLoc - | ModParens (ModExpBase f vn) SrcLoc - | ModImport FilePath (f FilePath) SrcLoc - -- ^ The contents of another file as a module. - | ModDecs [DecBase f vn] SrcLoc - | ModApply (ModExpBase f vn) (ModExpBase f vn) (f (M.Map VName VName)) (f (M.Map VName VName)) SrcLoc - -- ^ Functor application. - | ModAscript (ModExpBase f vn) (SigExpBase f vn) (f (M.Map VName VName)) SrcLoc - | ModLambda (ModParamBase f vn) - (Maybe (SigExpBase f vn, f (M.Map VName VName))) - (ModExpBase f vn) - SrcLoc +-- | Module expression. +data ModExpBase f vn + = ModVar (QualName vn) SrcLoc + | ModParens (ModExpBase f vn) SrcLoc + | ModImport FilePath (f FilePath) SrcLoc + -- ^ The contents of another file as a module. + | ModDecs [DecBase f vn] SrcLoc + | ModApply (ModExpBase f vn) (ModExpBase f vn) (f (M.Map VName VName)) (f (M.Map VName VName)) SrcLoc + -- ^ Functor application. + | ModAscript (ModExpBase f vn) (SigExpBase f vn) (f (M.Map VName VName)) SrcLoc + | ModLambda (ModParamBase f vn) + (Maybe (SigExpBase f vn, f (M.Map VName VName))) + (ModExpBase f vn) + SrcLoc deriving instance Showable f vn => Show (ModExpBase f vn) instance Located (ModExpBase f vn) where @@ -988,6 +1016,7 @@ locOf (ModAscript _ _ _ loc) = locOf loc locOf (ModLambda _ _ _ loc) = locOf loc +-- | A module binding. data ModBindBase f vn = ModBind { modName :: vn , modParams :: [ModParamBase f vn] @@ -1001,6 +1030,7 @@ instance Located (ModBindBase f vn) where locOf = locOf . modLocation +-- | A module parameter. data ModParamBase f vn = ModParam { modParamName :: vn , modParamType :: SigExpBase f vn , modParamAbs :: f [VName] diff --git a/src/Language/Futhark/Traversals.hs b/src/Language/Futhark/Traversals.hs --- a/src/Language/Futhark/Traversals.hs +++ b/src/Language/Futhark/Traversals.hs @@ -51,6 +51,7 @@ , mapOnPatternType = return } +-- | The class of things that we can map an 'ASTMapper' across. class ASTMappable x where -- | Map a monadic action across the immediate children of an -- object. Importantly, the 'astMap' action is not invoked for @@ -170,6 +171,8 @@ astMap tv (Match e cases (t, ext) loc) = Match <$> mapOnExp tv e <*> astMap tv cases <*> ((,) <$> traverse (mapOnPatternType tv) t <*> pure ext) <*> pure loc + astMap tv (Attr attr e loc) = + Attr attr <$> mapOnExp tv e <*> pure loc instance ASTMappable (LoopFormBase Info VName) where astMap tv (For i bound) = For <$> astMap tv i <*> astMap tv bound @@ -419,3 +422,5 @@ Constr name (map bareExp es) NoInfo loc bareExp (Match e cases _ loc) = Match (bareExp e) (fmap bareCase cases) (NoInfo,NoInfo) loc +bareExp (Attr attr e loc) = + Attr attr (bareExp e) loc diff --git a/src/Language/Futhark/TypeChecker.hs b/src/Language/Futhark/TypeChecker.hs --- a/src/Language/Futhark/TypeChecker.hs +++ b/src/Language/Futhark/TypeChecker.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Safe #-} -- | The type checker checks whether the program is type-consistent -- and adds type annotations and various other elaborations. The -- program does not need to have any particular properties for the @@ -19,7 +20,6 @@ import Control.Monad.Except import Control.Monad.Writer hiding (Sum) import Data.List (isPrefixOf) -import Data.Loc import Data.Maybe import Data.Either import Data.Ord diff --git a/src/Language/Futhark/TypeChecker/Modules.hs b/src/Language/Futhark/TypeChecker/Modules.hs --- a/src/Language/Futhark/TypeChecker/Modules.hs +++ b/src/Language/Futhark/TypeChecker/Modules.hs @@ -1,5 +1,6 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Safe #-} -- | Implementation of the Futhark module system (at least most of it; -- some is scattered elsewhere in the type checker). module Language.Futhark.TypeChecker.Modules @@ -12,7 +13,6 @@ import Control.Monad.Except import Control.Monad.Writer hiding (Sum) import Data.List (intersect) -import Data.Loc import Data.Maybe import Data.Either import Data.Ord diff --git a/src/Language/Futhark/TypeChecker/Monad.hs b/src/Language/Futhark/TypeChecker/Monad.hs --- a/src/Language/Futhark/TypeChecker/Monad.hs +++ b/src/Language/Futhark/TypeChecker/Monad.hs @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Trustworthy #-} -- | Main monad in which the type checker runs, as well as ancillary -- data definitions. module Language.Futhark.TypeChecker.Monad @@ -9,7 +10,6 @@ , runTypeM , askEnv , askImportName - , checkQualNameWithEnv , bindSpaced , qualifyTypeVars , lookupMTy @@ -17,10 +17,9 @@ , localEnv , TypeError(..) - , unexpectedType - , undefinedType , unappliedFunctor - , unknownVariableError + , unknownVariable + , unknownType , underscoreUse , Notes , aNote @@ -61,7 +60,6 @@ import Control.Monad.RWS.Strict import Control.Monad.Identity import Data.List (isPrefixOf, find) -import Data.Loc import Data.Maybe import Data.Either import qualified Data.Map.Strict as M @@ -81,6 +79,7 @@ -- | A note with extra information regarding a type error. newtype Note = Note Doc +-- | A collection of 'Note's. newtype Notes = Notes [Note] deriving (Semigroup, Monoid) @@ -90,6 +89,7 @@ instance Pretty Notes where ppr (Notes notes) = foldMap (((line<>line)<>) . ppr) notes +-- | A single note. aNote :: Pretty a => a -> Notes aNote = Notes . pure . Note . ppr @@ -101,37 +101,32 @@ text (inRed $ "Error at " <> locStr loc <> ":") msg <> ppr notes -unexpectedType :: MonadTypeChecker m => SrcLoc -> StructType -> [StructType] -> m a -unexpectedType loc _ [] = - typeError loc mempty $ - "Type of expression at" <+> text (locStr loc) <+> - "cannot have any type - possibly a bug in the type checker." -unexpectedType loc t ts = - typeError loc mempty $ - "Type of expression at" <+> text (locStr loc) <+> "must be one of" <+> - commasep (map ppr ts) <> ", but is" <+> - ppr t <> "." - -undefinedType :: MonadTypeChecker m => SrcLoc -> QualName Name -> m a -undefinedType loc name = - typeError loc mempty $ "Unknown type" <+> ppr name <> "." - +-- | An unexpected functor appeared! unappliedFunctor :: MonadTypeChecker m => SrcLoc -> m a unappliedFunctor loc = typeError loc mempty "Cannot have parametric module here." -unknownVariableError :: MonadTypeChecker m => - Namespace -> QualName Name -> SrcLoc -> m a -unknownVariableError space name loc = +-- | An unknown variable was referenced. +unknownVariable :: MonadTypeChecker m => + Namespace -> QualName Name -> SrcLoc -> m a +unknownVariable space name loc = typeError loc mempty $ "Unknown" <+> ppr space <+> pquote (ppr name) +-- | An unknown type was referenced. +unknownType :: MonadTypeChecker m => SrcLoc -> QualName Name -> m a +unknownType loc name = + typeError loc mempty $ "Unknown type" <+> ppr name <> "." + +-- | A name prefixed with an underscore was used. underscoreUse :: MonadTypeChecker m => SrcLoc -> QualName Name -> m a underscoreUse loc name = typeError loc mempty $ "Use of" <+> pquote (ppr name) <> ": variables prefixed with underscore may not be accessed." +-- | A mapping from import strings to 'Env's. This is used to resolve +-- @import@ declarations. type ImportTable = M.Map String Env data Context = Context { contextEnv :: Env @@ -152,6 +147,7 @@ MonadState VNameSource, MonadError TypeError) +-- | Run a 'TypeM' computation. runTypeM :: Env -> ImportTable -> ImportName -> VNameSource -> TypeM a -> Either TypeError (a, Warnings, VNameSource) @@ -159,6 +155,7 @@ (x, src', ws) <- runExcept $ runRWST m (Context env imports fpath) src return (x, ws, src') +-- | Retrieve the current 'Env'. askEnv :: TypeM Env askEnv = asks contextEnv @@ -166,12 +163,14 @@ askImportName :: TypeM ImportName askImportName = asks contextImportName +-- | Look up a module type. lookupMTy :: SrcLoc -> QualName Name -> TypeM (QualName VName, MTy) lookupMTy loc qn = do (scope, qn'@(QualName _ name)) <- checkQualNameWithEnv Signature qn loc (qn',) <$> maybe explode return (M.lookup name $ envSigTable scope) - where explode = unknownVariableError Signature qn loc + where explode = unknownVariable Signature qn loc +-- | Look up an import. lookupImport :: SrcLoc -> FilePath -> TypeM (FilePath, Env) lookupImport loc file = do imports <- asks contextImportTable @@ -183,11 +182,16 @@ "Known:" <+> commasep (map text (M.keys imports)) Just scope -> return (canonical_import, scope) +-- | Evaluate a 'TypeM' computation within an extended (/not/ +-- replaced) environment. localEnv :: Env -> TypeM a -> TypeM a localEnv env = local $ \ctx -> let env' = env <> contextEnv ctx in ctx { contextEnv = env' } +-- | Monads that support type checking. The reason we have this +-- internal interface is because we use distinct monads for checking +-- expressions and declarations. class Monad m => MonadTypeChecker m where warn :: Located loc => loc -> String -> m () @@ -213,9 +217,13 @@ typeError :: Located loc => loc -> Notes -> Doc -> m a +-- | Elaborate the given name in the given namespace at the given +-- location, producing the corresponding unique 'VName'. checkName :: MonadTypeChecker m => Namespace -> Name -> SrcLoc -> m VName checkName space name loc = qualLeaf <$> checkQualName space (qualName name) loc +-- | Map source-level names do fresh unique internal names, and +-- evaluate a type checker context with the mapping active. bindSpaced :: MonadTypeChecker m => [(Namespace, Name)] -> m a -> m a bindSpaced names body = do names' <- mapM (newID . snd) names @@ -246,20 +254,20 @@ outer_env <- askEnv (scope, qn'@(QualName qs name)) <- checkQualNameWithEnv Type qn loc case M.lookup name $ envTypeTable scope of - Nothing -> undefinedType loc qn + Nothing -> unknownType loc qn Just (TypeAbbr l ps def) -> return (qn', ps, qualifyTypeVars outer_env mempty qs def, l) lookupMod loc qn = do (scope, qn'@(QualName _ name)) <- checkQualNameWithEnv Term qn loc case M.lookup name $ envModTable scope of - Nothing -> unknownVariableError Term qn loc + Nothing -> unknownVariable Term qn loc Just m -> return (qn', m) lookupVar loc qn = do outer_env <- askEnv (env, qn'@(QualName qs name)) <- checkQualNameWithEnv Term qn loc case M.lookup name $ envVtable env of - Nothing -> unknownVariableError Term qn loc + Nothing -> unknownVariable Term qn loc Just (BoundV _ t) | "_" `isPrefixOf` baseString name -> underscoreUse loc qn | otherwise -> @@ -290,7 +298,7 @@ | Just name' <- M.lookup (space, name) $ envNameMap scope = return (scope, name') | otherwise = - unknownVariableError space qn loc + unknownVariable space qn loc descend scope (q:qs) | Just (QualName _ q') <- M.lookup (Term, q) $ envNameMap scope, @@ -301,9 +309,9 @@ return (scope', QualName (q':qs') name') ModFun{} -> unappliedFunctor loc | otherwise = - unknownVariableError space qn loc + unknownVariable space qn loc --- Try to prepend qualifiers to the type names such that they +-- | Try to prepend qualifiers to the type names such that they -- represent how to access the type in some scope. qualifyTypeVars :: ASTMappable t => Env -> [VName] -> [VName] -> t -> t qualifyTypeVars outer_env except ref_qs = runIdentity . astMap mapper @@ -337,34 +345,43 @@ reachable qs' name env' | otherwise = False +-- | Turn a 'Left' 'TypeError' into an actual error. badOnLeft :: Either TypeError a -> TypeM a badOnLeft = either throwError return +-- | All signed integer types. anySignedType :: [PrimType] anySignedType = map Signed [minBound .. maxBound] +-- | All unsigned integer types. anyUnsignedType :: [PrimType] anyUnsignedType = map Unsigned [minBound .. maxBound] +-- | All integer types. anyIntType :: [PrimType] anyIntType = anySignedType ++ anyUnsignedType +-- | All floating-point types. anyFloatType :: [PrimType] anyFloatType = map FloatType [minBound .. maxBound] +-- | All number types. anyNumberType :: [PrimType] anyNumberType = anyIntType ++ anyFloatType +-- | All primitive types. anyPrimType :: [PrimType] anyPrimType = Bool : anyIntType ++ anyFloatType --- Name handling +-- | The 'NameMap' corresponding to the intrinsics module. intrinsicsNameMap :: NameMap intrinsicsNameMap = M.fromList $ map mapping $ M.toList intrinsics where mapping (v, IntrinsicType{}) = ((Type, baseName v), QualName [] v) mapping (v, _) = ((Term, baseName v), QualName [] v) +-- | The names that are available in the initial environment. topLevelNameMap :: NameMap topLevelNameMap = M.filterWithKey (\k _ -> atTopLevel k) intrinsicsNameMap where atTopLevel :: (Namespace, Name) -> Bool diff --git a/src/Language/Futhark/TypeChecker/Terms.hs b/src/Language/Futhark/TypeChecker/Terms.hs --- a/src/Language/Futhark/TypeChecker/Terms.hs +++ b/src/Language/Futhark/TypeChecker/Terms.hs @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleInstances, DeriveFunctor #-} {-# Language TupleSections #-} {-# Language OverloadedStrings #-} +{-# LANGUAGE Trustworthy #-} -- | Facilities for type-checking Futhark terms. Checking a term -- requires a little more context to track uniqueness and such. -- @@ -26,7 +27,6 @@ import Data.Either import Data.List (isPrefixOf, foldl', find, (\\), nub, transpose, sort, group) import qualified Data.List.NonEmpty as NE -import Data.Loc import Data.Maybe import qualified Data.Map.Strict as M import qualified Data.Set as S @@ -36,11 +36,12 @@ import Language.Futhark hiding (unscopeType) import Language.Futhark.Semantic (includeToString) import Language.Futhark.Traversals -import Language.Futhark.TypeChecker.Monad hiding (BoundV, checkQualNameWithEnv) +import Language.Futhark.TypeChecker.Monad hiding (BoundV) import Language.Futhark.TypeChecker.Types hiding (checkTypeDecl) import Language.Futhark.TypeChecker.Unify hiding (Usage) import qualified Language.Futhark.TypeChecker.Types as Types import qualified Language.Futhark.TypeChecker.Monad as TypeM +import Futhark.IR.Primitive (intByteSize) import Futhark.Util.Pretty hiding (space, bool, group) --- Uniqueness @@ -484,14 +485,14 @@ outer_env <- liftTypeM askEnv (scope, qn'@(QualName qs name)) <- checkQualNameWithEnv Type qn loc case M.lookup name $ scopeTypeTable scope of - Nothing -> undefinedType loc qn + Nothing -> unknownType loc qn Just (TypeAbbr l ps def) -> return (qn', ps, qualifyTypeVars outer_env (map typeParamName ps) qs def, l) lookupMod loc qn = do (scope, qn'@(QualName _ name)) <- checkQualNameWithEnv Term qn loc case M.lookup name $ scopeModTable scope of - Nothing -> unknownVariableError Term qn loc + Nothing -> unknownVariable Term qn loc Just m -> return (qn', m) lookupVar loc qn = do @@ -555,7 +556,7 @@ | Just name' <- M.lookup (space, name) $ scopeNameMap scope = return (scope, name') | otherwise = - unknownVariableError space qn loc + unknownVariable space qn loc descend scope (q:qs) | Just (QualName _ q') <- M.lookup (Term, q) $ scopeNameMap scope, @@ -570,7 +571,7 @@ return (scope', QualName (q':qs') name') ModFun{} -> unappliedFunctor loc | otherwise = - unknownVariableError space qn loc + unknownVariable space qn loc checkIntrinsic :: Namespace -> QualName Name -> SrcLoc -> TermTypeM (TermScope, QualName VName) checkIntrinsic space qn@(QualName _ name) loc @@ -581,7 +582,7 @@ scope <- asks termScope return (scope, v) | otherwise = - unknownVariableError space qn loc + unknownVariable space qn loc -- | Wrap 'Types.checkTypeDecl' to also perform an observation of -- every size in the type. @@ -591,7 +592,7 @@ mapM_ observeDim $ nestedDims $ unInfo $ expandedType tdecl' return tdecl' where observeDim (NamedDim v) = - observe $ Ident (qualLeaf v) (Info $ Scalar $ Prim $ Signed Int32) noLoc + observe $ Ident (qualLeaf v) (Info $ Scalar $ Prim $ Signed Int32) mempty observeDim _ = return () -- | Instantiate a type scheme with fresh type variables for its type @@ -659,6 +660,17 @@ "A unique tuple element of return value of" <+> pquote (pprName fname) <+> "is aliased to some other tuple component." +unexpectedType :: MonadTypeChecker m => SrcLoc -> StructType -> [StructType] -> m a +unexpectedType loc _ [] = + typeError loc mempty $ + "Type of expression at" <+> text (locStr loc) <+> + "cannot have any type - possibly a bug in the type checker." +unexpectedType loc t ts = + typeError loc mempty $ + "Type of expression at" <+> text (locStr loc) <+> "must be one of" <+> + commasep (map ppr ts) <> ", but is" <+> + ppr t <> "." + --- Basic checking -- | Determine if the two types of identical, ignoring uniqueness. @@ -1017,7 +1029,7 @@ unifies :: String -> StructType -> Exp -> TermTypeM Exp unifies why t e = do - unify (mkUsage (srclocOf e) why) t =<< toStruct <$> expType e + unify (mkUsage (srclocOf e) why) t . toStruct =<< expType e return e -- The closure of a lambda or local function are those variables that @@ -1369,7 +1381,7 @@ -- We fake an ident here, but it's OK as it can't be a size -- anyway. - let fake_ident = Ident name' (Info $ fromStruct ftype) noLoc + let fake_ident = Ident name' (Info $ fromStruct ftype) mempty (body_t, _) <- unscopeType loc (M.singleton name' fake_ident) =<< expTypeFully body' @@ -1469,7 +1481,10 @@ return $ Index e' idxes' (Info t'', Info retext) loc -checkExp (Unsafe e loc) = +checkExp (Unsafe e loc) = do + warn loc $ + "The \"unsafe\" keyword is deprecated and will be removed very soon.\n" ++ + "Remove \"unsafe\" or replace with #[unsafe]." Unsafe <$> checkExp e <*> pure loc checkExp (Assert e1 e2 NoInfo loc) = do @@ -1879,6 +1894,9 @@ "type returned from pattern match" t return $ Match e' cs' (Info t, Info retext) loc +checkExp (Attr info e loc) = + Attr info <$> checkExp e <*> pure loc + checkCases :: PatternType -> NE.NonEmpty (CaseBase NoInfo Name) -> TermTypeM (NE.NonEmpty (CaseBase Info VName), PatternType, [VName]) @@ -2028,7 +2046,7 @@ case col of [] -> [] ((i, _):_) -> unmatched (wilder i pc) (map snd col) - wilder i pc s = (`PatternParens` noLoc) <$> wildPattern pc i s + wilder i pc s = (`PatternParens` mempty) <$> wildPattern pc i s in concatMap findUnmatched transposed _ -> unmatched' Scalar (Prim t) | not (any idOrWild ps') -> @@ -2089,16 +2107,16 @@ buildConstr m c = let t = Scalar $ Sum m cs = m M.! c - wildCS = map (\ct -> Wildcard (Info ct) noLoc) cs + wildCS = map (\ct -> Wildcard (Info ct) mempty) cs in if null wildCS - then PatternConstr c (Info t) [] noLoc - else PatternParens (PatternConstr c (Info t) wildCS noLoc) noLoc + then PatternConstr c (Info t) [] mempty + else PatternParens (PatternConstr c (Info t) wildCS mempty) mempty buildBool t b = - PatternLit (Literal (BoolValue b) noLoc) (Info (addSizes t)) noLoc + PatternLit (Literal (BoolValue b) mempty) (Info (addSizes t)) mempty buildId t n = -- The VName tag here will never be used since the value -- exists exclusively for printing warnings. - Id (VName (nameFromString n) (-1)) t noLoc + Id (VName (nameFromString n) (-1)) t mempty checkIdent :: IdentBase NoInfo Name -> TermTypeM Ident checkIdent (Ident name _ loc) = do @@ -2312,6 +2330,9 @@ consumeArg loc at Consume = return [consumption (aliases at) loc] consumeArg loc at _ = return [observation (aliases at) loc] +-- | Type-check a single expression in isolation. This expression may +-- turn out to be polymorphic, in which case the list of type +-- parameters will be non-empty. checkOneExp :: UncheckedExp -> TypeM ([TypeParam], Exp) checkOneExp e = fmap fst . runTermTypeM $ do e' <- checkExp e @@ -2322,6 +2343,7 @@ e'' <- updateTypes e' checkUnmatched e'' causalityCheck e'' + literalOverflowCheck e'' return (tparams, e'') -- Verify that all sum type constructors and empty array literals have @@ -2422,6 +2444,33 @@ align (textwrap "Bind the expression producing" <+> pquote (pprName d) <+> "with 'let' beforehand.") +-- | Traverse the expression, emitting warnings if any of the literals overflow +-- their inferred types +-- +-- Note: currently unable to detect float underflow (such as 1e-400 -> 0) +literalOverflowCheck :: Exp -> TermTypeM () +literalOverflowCheck = void . check + where check e@(IntLit x ty loc) = e <$ case ty of + Info (Scalar (Prim t)) -> warnBounds (inBoundsI x t) x t loc + _ -> error "Inferred type of int literal is not a number" + check e@(FloatLit x ty loc) = e <$ case ty of + Info (Scalar (Prim (FloatType t))) -> warnBounds (inBoundsF x t) x t loc + _ -> error "Inferred type of float literal is not a float" + check e@(Negate (IntLit x ty loc1) loc2) = e <$ case ty of + Info (Scalar (Prim t)) -> warnBounds (inBoundsI (-x) t) (-x) t (loc1 <> loc2) + _ -> error "Inferred type of int literal is not a number" + check e = astMap identityMapper{mapOnExp = check} e + bitWidth ty = 8 * intByteSize ty :: Int + inBoundsI x (Signed t) = x >= -2^(bitWidth t - 1) && x < 2^(bitWidth t - 1) + inBoundsI x (Unsigned t) = x >= 0 && x < 2^bitWidth t + inBoundsI x (FloatType Float32) = not $ isInfinite (fromIntegral x :: Float) + inBoundsI x (FloatType Float64) = not $ isInfinite (fromIntegral x :: Double) + inBoundsI _ Bool = error "Inferred type of int literal is not a number" + inBoundsF x Float32 = not $ isInfinite (realToFrac x :: Float) + inBoundsF x Float64 = not $ isInfinite x + warnBounds inBounds x ty loc = unless inBounds + $ warn loc $ "Literal " <> show x <> " out of bounds for inferred type " <> pretty ty <> "." + -- | Type-check a top-level (or module-level) function definition. -- Despite the name, this is also used for checking constant -- definitions, by treating them as 0-ary functions. @@ -2451,6 +2500,8 @@ -- Check if the function body can actually be evaluated. causalityCheck body'' + + literalOverflowCheck body'' bindSpaced [(Term, fname)] $ do fname' <- checkName Term fname loc diff --git a/src/Language/Futhark/TypeChecker/Types.hs b/src/Language/Futhark/TypeChecker/Types.hs --- a/src/Language/Futhark/TypeChecker/Types.hs +++ b/src/Language/Futhark/TypeChecker/Types.hs @@ -1,6 +1,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Safe #-} +-- | Type checker building blocks that do not involve unification. module Language.Futhark.TypeChecker.Types ( checkTypeExp , checkTypeDecl @@ -28,7 +30,6 @@ import Control.Monad.State import Data.Bifunctor import Data.List (foldl', sort, nub) -import Data.Loc import Data.Maybe import qualified Data.Map.Strict as M @@ -98,6 +99,7 @@ subuniqueOf Nonunique Unique = False subuniqueOf _ _ = True +-- | Use 'checkTypeExp' to check a type declaration. checkTypeDecl :: MonadTypeChecker m => TypeDeclBase NoInfo Name -> m (TypeDeclBase Info VName, Liftedness) @@ -106,6 +108,9 @@ (t', st, l) <- checkTypeExp t return (TypeDecl t' $ Info st, l) +-- | Type-check a single 'TypeExp', returning the checked 'TypeExp', +-- its fully expanded type (modulo yet-unelaborated type variables), +-- and whether it is potentially higher-order. checkTypeExp :: MonadTypeChecker m => TypeExp Name -> m (TypeExp VName, StructType, Liftedness) @@ -288,6 +293,9 @@ check _ TEArray{} = return () check _ TEVar{} = return () +-- | @checkTypeParams ps m@ checks the type parameters @ps@, then +-- invokes the continuation @m@ with the checked parameters, while +-- extending the monadic name map with @ps@. checkTypeParams :: MonadTypeChecker m => [TypeParamBase Name] -> ([TypeParamBase VName] -> m a) @@ -321,12 +329,15 @@ typeParamToArg (TypeParamType _ v ploc) = TypeArgType (Scalar $ TypeVar () Nonunique (typeName v) []) ploc +-- | A substitution for when using 'substituteTypes'. data TypeSub = TypeSub TypeBinding | DimSub (DimDecl VName) deriving (Show) +-- | A collection of type substitutions. type TypeSubs = M.Map VName TypeSub +-- | Apply type substitutions to the given type. substituteTypes :: Monoid als => TypeSubs -> TypeBase (DimDecl VName) als -> TypeBase (DimDecl VName) als substituteTypes substs ot = case ot of Array als u at shape -> diff --git a/src/Language/Futhark/TypeChecker/Unify.hs b/src/Language/Futhark/TypeChecker/Unify.hs --- a/src/Language/Futhark/TypeChecker/Unify.hs +++ b/src/Language/Futhark/TypeChecker/Unify.hs @@ -2,6 +2,9 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Trustworthy #-} +-- | Implementation of unification and other core type system building +-- blocks. module Language.Futhark.TypeChecker.Unify ( Constraint(..) , Usage @@ -42,7 +45,6 @@ import Control.Monad.State import Data.Bifoldable (biany) import Data.List (intersect) -import Data.Loc import Data.Maybe import qualified Data.Map.Strict as M import qualified Data.Set as S @@ -72,14 +74,20 @@ ppr (Matching s) = s +-- | Unification failures can occur deep down inside complicated types +-- (consider nested records). We leave breadcrumbs behind us so we +-- can report the path we took to find the mismatch. newtype BreadCrumbs = BreadCrumbs [BreadCrumb] +-- | An empty path. noBreadCrumbs :: BreadCrumbs noBreadCrumbs = BreadCrumbs [] +-- | Is the path empty? hasNoBreadCrumbs :: BreadCrumbs -> Bool hasNoBreadCrumbs (BreadCrumbs xs) = null xs +-- | Drop a breadcrumb on the path behind you. breadCrumb :: BreadCrumb -> BreadCrumbs -> BreadCrumbs breadCrumb (MatchingFields xs) (BreadCrumbs (MatchingFields ys : bcs)) = BreadCrumbs $ MatchingFields (ys++xs) : bcs @@ -94,9 +102,12 @@ data Usage = Usage (Maybe String) SrcLoc deriving (Show) +-- | Construct a 'Usage' from a location and a description. mkUsage :: SrcLoc -> String -> Usage mkUsage = flip (Usage . Just) +-- | Construct a 'Usage' that has just a location, but no particular +-- description. mkUsage' :: SrcLoc -> Usage mkUsage' = Usage Nothing @@ -108,10 +119,11 @@ locOf (Usage _ loc) = locOf loc -- | The level at which a type variable is bound. Higher means --- deeper. We can only unify a type variable at level 'i' with a type --- 't' if all type names that occur in 't' are at most at level 'i'. +-- deeper. We can only unify a type variable at level @i@ with a type +-- @t@ if all type names that occur in @t@ are at most at level @i@. type Level = Int +-- | A constraint on a yet-ambiguous type variable. data Constraint = NoConstraint Liftedness Usage | ParamType Liftedness SrcLoc | Constraint StructType Usage @@ -230,6 +242,9 @@ "One branch returns array of type: " <> align (ppr t1) "The other an array of type: " <> align (ppr t2) +-- | Retrieve notes describing the purpose or origin of the given +-- 'DimDecl'. The location is used as the *current* location, for the +-- purpose of reporting relative locations. dimNotes :: (Located a, MonadUnify m) => a -> DimDecl VName -> m Notes dimNotes ctx (NamedDim d) = do c <- M.lookup (qualLeaf d) <$> getConstraints @@ -245,6 +260,8 @@ fmap mconcat . mapM (dimNotes ctx . NamedDim . qualName) . S.toList . typeDimNames +-- | Monads that which to perform unification must implement this type +-- class. class Monad m => MonadUnify m where getConstraints :: m Constraints putConstraints :: Constraints -> m () @@ -264,10 +281,12 @@ unifyError :: Located loc => loc -> Notes -> BreadCrumbs -> Doc -> m a +-- | Replace all type variables with their substitution. normTypeFully :: (Substitutable a, MonadUnify m) => a -> m a normTypeFully t = do constraints <- getConstraints return $ applySubst (`lookupSubst` constraints) t +-- | Replace any top-level type variable with its substitution. normType :: MonadUnify m => StructType -> m StructType normType t@(Scalar (TypeVar _ _ (TypeName [] v) [])) = do constraints <- getConstraints @@ -276,6 +295,7 @@ _ -> return t normType t = return t +-- | Replace any top-level type variable with its substitution. normPatternType :: MonadUnify m => PatternType -> m PatternType normPatternType t@(Scalar (TypeVar als u (TypeName [] v) [])) = do constraints <- getConstraints @@ -291,6 +311,8 @@ rigidConstraint UnknowableSize{} = True rigidConstraint _ = False +-- | Replace 'AnyDim' dimensions that occur as 'PosImmediate' or +-- 'PosParam' with a fresh 'NamedDim'. instantiateEmptyArrayDims :: MonadUnify m => SrcLoc -> String -> Rigidity -> TypeBase (DimDecl VName) als @@ -648,6 +670,7 @@ Scalar $ Sum $ (fmap . fmap) removeUniqueness cs removeUniqueness t = t `setUniqueness` Nonunique +-- | Assert that this type must be one of the given primitive types. mustBeOneOf :: MonadUnify m => [PrimType] -> Usage -> StructType -> m () mustBeOneOf [req_t] usage t = unify usage (Scalar (Prim req_t)) t mustBeOneOf ts usage t = do @@ -695,6 +718,7 @@ unifyError usage mempty noBreadCrumbs $ "Cannot constrain type to one of" <+> commasep (map ppr ts) +-- | Assert that this type must support equality. equalityType :: (MonadUnify m, Pretty (ShapeDecl dim), Monoid as) => Usage -> TypeBase dim as -> m () equalityType usage t = do @@ -743,6 +767,7 @@ text (locStr ploc) <+> "may be a function." _ -> return () +-- | Assert that this type must be zero-order. zeroOrderType :: (MonadUnify m, Pretty (ShapeDecl dim), Monoid as) => Usage -> String -> TypeBase dim as -> m () zeroOrderType usage desc = @@ -829,6 +854,7 @@ _ -> do unify usage (toStruct t) $ Scalar $ Record $ M.singleton l l_type' return l_type +-- | Assert that some type must have a field with this name and type. mustHaveField :: MonadUnify m => Usage -> Name -> PatternType -> m PatternType mustHaveField usage = mustHaveFieldWith (unifyDims usage) usage noBreadCrumbs diff --git a/src/Language/Futhark/Warnings.hs b/src/Language/Futhark/Warnings.hs --- a/src/Language/Futhark/Warnings.hs +++ b/src/Language/Futhark/Warnings.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE Safe #-} +-- | A very simple representation of collections of warnings. +-- Warnings have a position (so they can be ordered), and their +-- 'Show'-instance produces a human-readable string. module Language.Futhark.Warnings ( Warnings , singleWarning @@ -5,11 +9,11 @@ import Data.Monoid import Data.List (sortOn, intercalate) -import Data.Loc import Prelude import Language.Futhark.Core (locStr) +import Futhark.Util.Loc -- | The warnings produced by the compiler. The 'Show' instance -- produces a human-readable description. @@ -32,5 +36,6 @@ "Warning at " ++ locStr loc ++ ":\n" ++ intercalate "\n" (map (" "<>) $ lines w) +-- | A single warning at the given location. singleWarning :: SrcLoc -> String -> Warnings singleWarning loc problem = Warnings [(loc, problem)] diff --git a/unittests/Futhark/Analysis/ScalExpTests.hs b/unittests/Futhark/Analysis/ScalExpTests.hs --- a/unittests/Futhark/Analysis/ScalExpTests.hs +++ b/unittests/Futhark/Analysis/ScalExpTests.hs @@ -18,7 +18,7 @@ import qualified Text.Megaparsec.Char.Lexer as L import Futhark.Analysis.ScalExp -import Futhark.Representation.AST hiding (constant, SDiv) +import Futhark.IR hiding (constant, SDiv) tests :: TestTree tests = testGroup "ScalExpTests" [] diff --git a/unittests/Futhark/IR/Mem/IxFun/Alg.hs b/unittests/Futhark/IR/Mem/IxFun/Alg.hs new file mode 100644 --- /dev/null +++ b/unittests/Futhark/IR/Mem/IxFun/Alg.hs @@ -0,0 +1,153 @@ +-- | A simple index operation representation. Every operation corresponds to a +-- constructor. +module Futhark.IR.Mem.IxFun.Alg + ( IxFun(..) + , iota + , offsetIndex + , permute + , rotate + , reshape + , slice + , rebase + , repeat + , shape + , index + ) +where + +import Prelude hiding (repeat, mod) + +import Futhark.IR.Syntax + (ShapeChange, DimChange(..), Slice, sliceDims, DimIndex(..), unitSlice) +import Futhark.IR.Prop +import Futhark.IR.Pretty () +import Futhark.Util.IntegralExp +import Futhark.Util.Pretty + +type Shape num = [num] +type Indices num = [num] +type Permutation = [Int] + +data IxFun num = Direct (Shape num) + | Permute (IxFun num) Permutation + | Rotate (IxFun num) (Indices num) + | Index (IxFun num) (Slice num) + | Reshape (IxFun num) (ShapeChange num) + | Repeat (IxFun num) [Shape num] (Shape num) + | OffsetIndex (IxFun num) num + | Rebase (IxFun num) (IxFun num) + deriving (Eq, Show) + +instance Pretty num => Pretty (IxFun num) where + ppr (Direct dims) = + text "Direct" <> parens (commasep $ map ppr dims) + ppr (Permute fun perm) = ppr fun <> ppr perm + ppr (Rotate fun offsets) = ppr fun <> brackets (commasep $ map ((text "+" <>) . ppr) offsets) + ppr (Index fun is) = ppr fun <> brackets (commasep $ map ppr is) + ppr (Reshape fun oldshape) = + ppr fun <> text "->reshape" <> + parens (commasep (map ppr oldshape)) + ppr (Repeat fun outer_shapes inner_shape) = + ppr fun <> text "->repeat" <> parens (commasep (map ppr $ outer_shapes++ [inner_shape])) + ppr (OffsetIndex fun i) = + ppr fun <> text "->offset_index" <> parens (ppr i) + ppr (Rebase new_base fun) = + text "rebase(" <> ppr new_base <> text ", " <> ppr fun <> text ")" + + +iota :: Shape num -> IxFun num +iota = Direct + +offsetIndex :: IxFun num -> num -> IxFun num +offsetIndex = OffsetIndex + +permute :: IxFun num -> Permutation -> IxFun num +permute = Permute + +rotate :: IxFun num -> Indices num -> IxFun num +rotate = Rotate + +repeat :: IxFun num -> [Shape num] -> Shape num -> IxFun num +repeat = Repeat + +slice :: IxFun num -> Slice num -> IxFun num +slice = Index + +rebase :: IxFun num -> IxFun num -> IxFun num +rebase = Rebase + +reshape :: IxFun num -> ShapeChange num -> IxFun num +reshape = Reshape + +shape :: IntegralExp num => + IxFun num -> Shape num +shape (Direct dims) = + dims +shape (Permute ixfun perm) = + rearrangeShape perm $ shape ixfun +shape (Rotate ixfun _) = + shape ixfun +shape (Index _ how) = + sliceDims how +shape (Reshape _ dims) = + map newDim dims +shape (Repeat ixfun outer_shapes inner_shape) = + concat (zipWith repeated outer_shapes (shape ixfun)) ++ inner_shape + where repeated outer_ds d = outer_ds ++ [d] +shape (OffsetIndex ixfun _) = + shape ixfun +shape (Rebase _ ixfun) = + shape ixfun + +index :: (IntegralExp num, Eq num) => + IxFun num -> Indices num -> num +index (Direct dims) is = + sum $ zipWith (*) is slicesizes + where slicesizes = drop 1 $ sliceSizes dims +index (Permute fun perm) is_new = + index fun is_old + where is_old = rearrangeShape (rearrangeInverse perm) is_new +index (Rotate fun offsets) is = + index fun $ zipWith mod (zipWith (+) is offsets) dims + where dims = shape fun +index (Index fun js) is = + index fun (adjust js is) + where adjust (DimFix j:js') is' = j : adjust js' is' + adjust (DimSlice j _ s:js') (i:is') = j + i * s : adjust js' is' + adjust _ _ = [] +index (Reshape fun newshape) is = + let new_indices = reshapeIndex (shape fun) (newDims newshape) is + in index fun new_indices +index (Repeat fun outer_shapes _) is = + -- Discard those indices that are just repeats. It is intentional + -- that we cut off those indices that correspond to the innermost + -- repeated dimensions. + index fun is' + where flags dims = replicate (length dims) True ++ [False] + is' = map snd $ filter (not . fst) $ zip (concatMap flags outer_shapes) is +index (OffsetIndex fun i) is = + case shape fun of + d : ds -> + index (Index fun (DimSlice i (d-i) 1 : map (unitSlice 0) ds)) is + [] -> error "index: OffsetIndex: underlying index function has rank zero" +index (Rebase new_base fun) is = + let fun' = case fun of + Direct old_shape -> + if old_shape == shape new_base + then new_base + else reshape new_base $ map DimCoercion old_shape + Permute ixfun perm -> + permute (rebase new_base ixfun) perm + Rotate ixfun offsets -> + rotate (rebase new_base ixfun) offsets + Index ixfun iis -> + slice (rebase new_base ixfun) iis + Reshape ixfun new_shape -> + reshape (rebase new_base ixfun) new_shape + Repeat ixfun outer_shapes inner_shape -> + repeat (rebase new_base ixfun) outer_shapes inner_shape + OffsetIndex ixfun s -> + offsetIndex (rebase new_base ixfun) s + r@Rebase{} -> + r + in index fun' is diff --git a/unittests/Futhark/IR/Mem/IxFunTests.hs b/unittests/Futhark/IR/Mem/IxFunTests.hs new file mode 100644 --- /dev/null +++ b/unittests/Futhark/IR/Mem/IxFunTests.hs @@ -0,0 +1,371 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Futhark.IR.Mem.IxFunTests + ( tests + ) +where + +import Prelude hiding (span, repeat) +import qualified Prelude as P +import qualified Data.List as DL + +import Test.Tasty +import Test.Tasty.HUnit + +import Futhark.IR.Syntax +import Futhark.IR.Syntax.Core() +import qualified Futhark.Util.Pretty as PR +import qualified Futhark.Util.IntegralExp as IE +import qualified Futhark.IR.Mem.IxFun as IxFunLMAD +import qualified Futhark.IR.Mem.IxFun.Alg as IxFunAlg + +import qualified Futhark.IR.Mem.IxFunWrapper as IxFunWrap +import Futhark.IR.Mem.IxFunWrapper + + +instance IE.IntegralExp Int where + quot = P.quot + rem = P.rem + div = P.div + mod = P.mod + sgn = Just . P.signum + + fromInt8 = fromInteger . toInteger + fromInt16 = fromInteger . toInteger + fromInt32 = fromInteger . toInteger + fromInt64 = fromInteger . toInteger + +allPoints :: [Int] -> [[Int]] +allPoints dims = + let total = product dims + strides = drop 1 $ DL.reverse $ scanl (*) 1 $ DL.reverse dims + in map (unflatInd strides) [0..total-1] + where unflatInd :: [Int] -> Int -> [Int] + unflatInd strides x = fst $ + foldl (\(res, acc) span -> + (res ++ [acc `P.div` span], acc `P.mod` span)) + ([], x) strides + +compareIxFuns :: IxFunLMAD.IxFun Int -> IxFunAlg.IxFun Int -> Assertion +compareIxFuns ixfunLMAD ixfunAlg = + let lmadShape = IxFunLMAD.shape ixfunLMAD + algShape = IxFunAlg.shape ixfunAlg + points = allPoints lmadShape + resLMAD = map (IxFunLMAD.index ixfunLMAD) points + resAlg = map (IxFunAlg.index ixfunAlg) points + errorMessage = "lmad ixfun: " ++ PR.pretty ixfunLMAD ++ "\n" ++ + "alg ixfun: " ++ PR.pretty ixfunAlg ++ "\n" ++ + "lmad shape: " ++ show lmadShape ++ "\n" ++ + "alg shape: " ++ show algShape ++ "\n" ++ + "lmad points length: " ++ show (length resLMAD) ++ "\n" ++ + "alg points length: " ++ show (length resAlg) ++ "\n" ++ + "lmad points: " ++ show resLMAD ++ "\n" ++ + "alg points: " ++ show resAlg + in (lmadShape == algShape && resLMAD == resAlg) @? errorMessage + +compareOps :: IxFunWrap.IxFun Int -> Assertion +compareOps (ixfunLMAD, ixfunAlg) = compareIxFuns ixfunLMAD ixfunAlg + +-- XXX: Clean this up. +n :: Int +n = 19 +slice3 :: [DimIndex Int] +slice3 = [ DimSlice 2 (n `P.div` 3) 3 + , DimFix (n `P.div` 2) + , DimSlice 1 (n `P.div` 2) 2 + ] + + +-- Actual tests. +tests :: TestTree +tests = testGroup "IxFunTests" + $ concat + [ test_iota + , test_slice_iota + , test_reshape_slice_iota1 + , test_permute_slice_iota + , test_repeat_slice_iota + , test_rotate_rotate_permute_slice_iota + , test_slice_rotate_permute_slice_iota1 + , test_slice_rotate_permute_slice_iota2 + , test_slice_rotate_permute_slice_iota3 + , test_permute_rotate_slice_permute_slice_iota + , test_reshape_rotate_iota + , test_reshape_permute_iota + , test_reshape_slice_iota2 + , test_reshape_slice_iota3 + , test_complex1 + , test_complex2 + , test_complex3 + , test_rebase1 + , test_rebase2 + , test_rebase3 + , test_rebase4_5 + , test_rebase6 + ] + +singleton :: TestTree -> [TestTree] +singleton = (: []) + +test_iota :: [TestTree] +test_iota = singleton $ testCase "iota" $ compareOps $ + iota [n] + +test_slice_iota :: [TestTree] +test_slice_iota = singleton $ testCase "slice . iota" $ compareOps $ + slice (iota [n, n, n]) slice3 + +test_reshape_slice_iota1 :: [TestTree] +test_reshape_slice_iota1 = singleton $ testCase "reshape . slice . iota 1" $ compareOps $ + reshape (slice (iota [n, n, n]) slice3) + [DimNew (n `P.div` 2), DimNew (n `P.div` 3)] + +test_permute_slice_iota :: [TestTree] +test_permute_slice_iota = singleton $ testCase "permute . slice . iota" $ compareOps $ + permute (slice (iota [n, n, n]) slice3) [1, 0] + +test_repeat_slice_iota :: [TestTree] +test_repeat_slice_iota = singleton $ testCase "repeat . slice . iota" $ compareOps $ + repeat (slice (iota [n, n, n]) slice3) [[2, 3], [3, 2]] [4, 4] + +test_rotate_rotate_permute_slice_iota :: [TestTree] +test_rotate_rotate_permute_slice_iota = + singleton $ testCase "rotate . rotate . permute . slice . iota" $ compareOps $ + let ixfun = permute (slice (iota [n, n, n]) slice3) [1, 0] + in rotate (rotate ixfun [2, 1]) [1, 2] + +test_slice_rotate_permute_slice_iota1 :: [TestTree] +test_slice_rotate_permute_slice_iota1 = + singleton $ testCase "slice . rotate . permute . slice . iota 1" $ compareOps $ + let slice2 = [ DimSlice 0 n 1 + , DimSlice 1 (n `P.div` 2) 2 + , DimSlice 0 n 1 + ] + slice13 = [ DimSlice 2 (n `P.div` 3) 3 + , DimSlice 0 (n `P.div` 2) 1 + , DimSlice 1 (n `P.div` 2) 2 + ] + ixfun = permute (slice (iota [n, n, n]) slice2) [2, 1, 0] + ixfun' = slice (rotate ixfun [3, 1, 2]) slice13 + in ixfun' + +test_slice_rotate_permute_slice_iota2 :: [TestTree] +test_slice_rotate_permute_slice_iota2 = + singleton $ testCase "slice . rotate . permute . slice . iota 2" $ compareOps $ + let slice2 = [ DimSlice 0 (n `P.div` 2) 1 + , DimFix (n `P.div` 2) + , DimSlice 0 (n `P.div` 3) 1 + ] + slice13 = [ DimSlice 2 (n `P.div` 3) 3 + , DimSlice 0 n 1 + , DimSlice 1 (n `P.div` 2) 2 + ] + ixfun = permute (slice (iota [n, n, n]) slice13) [2, 1, 0] + ixfun' = slice (rotate ixfun [3, 1, 2]) slice2 + in ixfun' + +test_slice_rotate_permute_slice_iota3 :: [TestTree] +test_slice_rotate_permute_slice_iota3 = + singleton $ testCase "slice . rotate . permute . slice . iota 3" $ compareOps $ + -- full-slice of (-1) stride + let ixfun = permute (slice (iota [n, n, n]) slice3) [1, 0] + ixfun' = rotate ixfun [2, 1] + + (n1, m1) = case IxFunLMAD.shape (fst ixfun') of + [a, b] -> (a, b) + _ -> error "expecting 2 dimensions at this point!" + negslice = [DimSlice 0 n1 1, DimSlice (m1 - 1) m1 (-1)] + ixfun'' = rotate (slice ixfun' negslice) [1,2] + in ixfun'' + +test_permute_rotate_slice_permute_slice_iota :: [TestTree] +test_permute_rotate_slice_permute_slice_iota = + singleton $ testCase "permute . rotate . slice . permute . slice . iota" $ compareOps $ + -- contiguousness + let slice33 = [ DimFix (n `P.div` 2) + , DimSlice (n - 1) (n `P.div` 3) (-1) + , DimSlice 0 n 1 + ] + ixfun = permute (slice (iota [n, n, n]) slice33) [1, 0] + m = n `P.div` 3 + slice1 = [DimSlice (n - 1) n (-1), DimSlice 2 (m - 2) 1] + ixfun' = permute (rotate (slice ixfun slice1) [1, 2]) [1, 0] + in ixfun' + +test_reshape_rotate_iota :: [TestTree] +test_reshape_rotate_iota = + -- negative reshape test + singleton $ testCase "reshape . rotate . iota" $ compareOps $ + let newdims = [DimNew (n * n), DimCoercion n] + in reshape (rotate (iota [n, n, n]) [1, 0, 0]) newdims + +test_reshape_permute_iota :: [TestTree] +test_reshape_permute_iota = + -- negative reshape test + singleton $ testCase "reshape . permute . iota" $ compareOps $ + let newdims = [DimNew (n * n), DimCoercion n] + in reshape (permute (iota [n, n, n]) [1, 2, 0]) newdims + +test_reshape_slice_iota2 :: [TestTree] +test_reshape_slice_iota2 = + -- negative reshape test + singleton $ testCase "reshape . slice . iota 2" $ compareOps $ + let newdims = [DimNew (n*n), DimCoercion n] + slc = [ DimFix (n `P.div` 2) + , DimSlice (n-1) n (-1) + , DimSlice 0 n 1 + , DimSlice (n-1) n (-1) + ] + in reshape (slice (iota [n, n, n, n]) slc) newdims + +test_reshape_slice_iota3 :: [TestTree] +test_reshape_slice_iota3 = + -- negative reshape test + singleton $ testCase "reshape . slice . iota 3" $ compareOps $ + let newdims = [DimNew (n*n), DimCoercion n] + slc = [ DimFix (n `P.div` 2) + , DimSlice 0 n 1 + , DimSlice 0 (n `P.div` 2) 1 + , DimSlice 0 n 1 + ] + in reshape (slice (iota [n, n, n, n]) slc) newdims + +test_complex1 :: [TestTree] +test_complex1 = + singleton $ testCase "reshape . permute . rotate . slice . permute . slice . iota 1" $ compareOps $ + let newdims = [ DimCoercion n + , DimCoercion n + , DimNew n + , DimCoercion ((n `P.div` 3) - 2) + ] + slice33 = [ DimSlice (n-1) (n `P.div` 3) (-1) + , DimSlice (n-1) n (-1) + , DimSlice (n-1) n (-1) + , DimSlice 0 n 1 + ] + ixfun = permute (slice (iota [n, n, n, n, n]) slice33) [3, 1, 2, 0] + m = n `P.div` 3 + slice1 = [DimSlice 0 n 1, DimSlice (n-1) n (-1), DimSlice (n-1) n (-1), DimSlice 1 (m-2) (-1)] + ixfun' = reshape (rotate (slice ixfun slice1) [1, 2, 3, 4]) newdims + in ixfun' + +test_complex2 :: [TestTree] +test_complex2 = + singleton $ testCase "reshape . permute . rotate . slice . permute . slice . iota 2" $ compareOps $ + let newdims = [ DimCoercion n + , DimNew (n*n) + , DimCoercion ((n `P.div` 3) - 2)] + slc2 = [ DimFix (n `P.div` 2) + , DimSlice (n-1) (n `P.div` 3) (-1) + , DimSlice (n-1) n (-1) + , DimSlice (n-1) n (-1) + , DimSlice 0 n 1 + ] + ixfun = permute (slice (iota [n, n, n, n, n]) slc2) [3, 1, 2, 0] + m = n `P.div` 3 + slice1 = [DimSlice 0 n 1, DimSlice (n-1) n (-1), DimSlice (n-1) n (-1), DimSlice 1 (m-2) (-1)] + ixfun' = reshape (rotate (slice ixfun slice1) [1, 0, 0, 2]) newdims + in ixfun' + +test_complex3 :: [TestTree] +test_complex3 = + singleton $ testCase "reshape . permute . rotate . slice . permute . slice . iota 3" $ compareOps $ + let newdims = [ DimCoercion 1 + , DimCoercion n + , DimNew (n*n) + , DimCoercion 2 + , DimCoercion ((n `P.div` 3) - 2) + ] + slc3 = [ DimFix (n `P.div` 2) + , DimSlice (n-1) (n `P.div` 3) (-1) + , DimSlice (n-1) n (-1) + , DimSlice (n-1) n (-1) + , DimSlice 0 n 1 + ] + ixfun = permute (slice (iota [n, n, n, n, n]) slc3) [3, 1, 2, 0] + m = n `P.div` 3 + slice1 = [DimSlice 0 n 1, DimSlice (n-1) n (-1), DimSlice (n-1) n (-1), DimSlice 1 (m-2) (-1)] + repeats = [[1],[],[],[2]] + ixfun' = reshape (repeat (rotate (slice ixfun slice1) [1, 0, 0, 2]) repeats []) newdims + in ixfun' + +test_rebase1 :: [TestTree] +test_rebase1 = + singleton $ testCase "rebase 1" $ compareOps $ + let slice_base = [ DimFix (n `P.div` 2) + , DimSlice 2 (n-2) 1 + , DimSlice 3 (n-3) 1 + ] + ixfn_base = rotate (permute (slice (iota [n, n, n]) slice_base) [1, 0]) [2, 1] + ixfn_orig = rotate (permute (iota [n-3, n-2]) [1, 0]) [1, 2] + ixfn_rebase = rebase ixfn_base ixfn_orig + in ixfn_rebase + +test_rebase2 :: [TestTree] +test_rebase2 = + singleton $ testCase "rebase 2" $ compareOps $ + let slice_base = [ DimFix (n `P.div` 2) + , DimSlice (n-1) (n-2) (-1) + , DimSlice (n-1) (n-3) (-1) + ] + slice_orig = [ DimSlice (n-4) (n-3) (-1) + , DimSlice (n-3) (n-2) (-1) + ] + ixfn_base = rotate (permute (slice (iota [n, n, n]) slice_base) [1, 0]) [2, 1] + ixfn_orig = rotate (permute (slice (iota [n-3, n-2]) slice_orig) [1, 0]) [1, 2] + ixfn_rebase = rebase ixfn_base ixfn_orig + in ixfn_rebase + +test_rebase3 :: [TestTree] +test_rebase3 = + singleton $ testCase "rebase full orig but not monotonic" $ compareOps $ + let n2 = (n-2) `P.div` 3 + n3 = (n-3) `P.div` 2 + slice_base = [ DimFix (n `P.div` 2) + , DimSlice (n-1) n2 (-3) + , DimSlice (n-1) n3 (-2) + ] + slice_orig = [ DimSlice (n3-1) n3 (-1) + , DimSlice (n2-1) n2 (-1) + ] + ixfn_base = rotate (permute (slice (iota [n, n, n]) slice_base) [1, 0]) [2, 1] + ixfn_orig = rotate (permute (slice (iota [n3, n2]) slice_orig) [1, 0]) [1, 2] + ixfn_rebase = rebase ixfn_base ixfn_orig + in ixfn_rebase + +test_rebase4_5 :: [TestTree] +test_rebase4_5 = + let n2 = (n-2) `P.div` 3 + n3 = (n-3) `P.div` 2 + slice_base = [ DimFix (n `P.div` 2) + , DimSlice (n-1) n2 (-3) + , DimSlice 3 n3 2 + ] + slice_orig = [ DimSlice (n3-1) n3 (-1) + , DimSlice 0 n2 1 + ] + ixfn_base = rotate (permute (slice (iota [n, n, n]) slice_base) [1, 0]) [2, 1] + ixfn_orig = rotate (permute (slice (iota [n3, n2]) slice_orig) [1, 0]) [1, 2] + in [ testCase "rebase mixed monotonicities" $ compareOps $ + rebase ixfn_base ixfn_orig + + , testCase "rebase repetitions and mixed monotonicities 1" $ compareOps $ + let ixfn_orig' = repeat ixfn_orig [[2, 2], [3, 3]] [2, 3] + in rebase ixfn_base ixfn_orig' + ] + +test_rebase6 :: [TestTree] +test_rebase6 = + singleton $ testCase "rebase repetitions and mixed monotonicities 2" $ compareOps $ + let n2 = (n-2) `P.div` 3 + n3 = (n-3) `P.div` 2 + slice_base = [ DimFix (n `P.div` 2) + , DimSlice (n-1) n2 (-3) + ] + slice_orig = [ DimSlice (n3-1) n3 (-1) + , DimSlice 0 n2 1 + ] + ixfn_base = permute (repeat (rotate (slice (iota [n, n]) slice_base) [1]) [[], []] [n3]) [1, 0] + ixfn_orig = rotate (permute (slice (iota [n3, n2]) slice_orig) [1, 0]) [1, 2] + ixfn_orig' = repeat ixfn_orig [[2, 2],[3, 3]] [2, 3] + ixfn_rebase = rebase ixfn_base ixfn_orig' + in ixfn_rebase diff --git a/unittests/Futhark/IR/Mem/IxFunWrapper.hs b/unittests/Futhark/IR/Mem/IxFunWrapper.hs new file mode 100644 --- /dev/null +++ b/unittests/Futhark/IR/Mem/IxFunWrapper.hs @@ -0,0 +1,55 @@ +-- | Perform index function operations in both algebraic and LMAD +-- representations. +module Futhark.IR.Mem.IxFunWrapper + ( IxFun + , iota + , permute + , rotate + , reshape + , slice + , rebase + , repeat + ) +where + +import Prelude hiding (repeat) + +import Futhark.Util.IntegralExp +import Futhark.IR.Syntax (ShapeChange, Slice) +import qualified Futhark.IR.Mem.IxFun as I +import qualified Futhark.IR.Mem.IxFun.Alg as IA + + +type Shape num = [num] +type Indices num = [num] +type Permutation = [Int] + +type IxFun num = (I.IxFun num, IA.IxFun num) + +iota :: IntegralExp num => + Shape num -> IxFun num +iota x = (I.iota x, IA.iota x) + +permute :: IntegralExp num => + IxFun num -> Permutation -> IxFun num +permute (l, a) x = (I.permute l x, IA.permute a x) + +rotate :: (Eq num, IntegralExp num) => + IxFun num -> Indices num -> IxFun num +rotate (l, a) x = (I.rotate l x, IA.rotate a x) + +repeat :: (Eq num, IntegralExp num) => + IxFun num -> [Shape num] -> Shape num -> IxFun num +repeat (l, a) x y = (I.repeat l x y, IA.repeat a x y) + +reshape :: (Eq num, IntegralExp num) => + IxFun num -> ShapeChange num -> IxFun num +reshape (l, a) x = (I.reshape l x, IA.reshape a x) + +slice :: (Eq num, IntegralExp num) => + IxFun num -> Slice num -> IxFun num +slice (l, a) x = (I.slice l x, IA.slice a x) + +rebase :: (Eq num, IntegralExp num) => + IxFun num -> IxFun num -> IxFun num +rebase (l, a) (l1, a1) = (I.rebase l l1, IA.rebase a a1) diff --git a/unittests/Futhark/IR/PrimitiveTests.hs b/unittests/Futhark/IR/PrimitiveTests.hs new file mode 100644 --- /dev/null +++ b/unittests/Futhark/IR/PrimitiveTests.hs @@ -0,0 +1,61 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Futhark.IR.PrimitiveTests + ( tests + , arbitraryPrimValOfType + ) + where + +import Control.Applicative + +import Test.QuickCheck +import Test.Tasty +import Test.Tasty.HUnit + +import Prelude + +import Futhark.IR.Primitive + +tests :: TestTree +tests = testGroup "PrimitiveTests" propPrimValuesHaveRightType + +propPrimValuesHaveRightType :: [TestTree] +propPrimValuesHaveRightType = [ testCase (show t ++ " has blank of right type") $ + primValueType (blankPrimValue t) @?= t + | t <- [minBound..maxBound] + ] + +instance Arbitrary IntType where + arbitrary = elements [minBound..maxBound] + +instance Arbitrary FloatType where + arbitrary = elements [minBound..maxBound] + +instance Arbitrary PrimType where + arbitrary = elements [minBound..maxBound] + +instance Arbitrary IntValue where + arbitrary = oneof [ Int8Value <$> arbitrary + , Int16Value <$> arbitrary + , Int32Value <$> arbitrary + , Int64Value <$> arbitrary ] + +instance Arbitrary FloatValue where + arbitrary = oneof [ Float32Value <$> arbitrary + , Float64Value <$> arbitrary ] + +instance Arbitrary PrimValue where + arbitrary = oneof [ IntValue <$> arbitrary + , FloatValue <$> arbitrary + , BoolValue <$> arbitrary + , pure Checked + ] + +arbitraryPrimValOfType :: PrimType -> Gen PrimValue +arbitraryPrimValOfType (IntType Int8) = IntValue . Int8Value <$> arbitrary +arbitraryPrimValOfType (IntType Int16) = IntValue . Int16Value <$> arbitrary +arbitraryPrimValOfType (IntType Int32) = IntValue . Int32Value <$> arbitrary +arbitraryPrimValOfType (IntType Int64) = IntValue . Int64Value <$> arbitrary +arbitraryPrimValOfType (FloatType Float32) = FloatValue . Float32Value <$> arbitrary +arbitraryPrimValOfType (FloatType Float64) = FloatValue . Float32Value <$> arbitrary +arbitraryPrimValOfType Bool = BoolValue <$> arbitrary +arbitraryPrimValOfType Cert = return Checked diff --git a/unittests/Futhark/IR/Prop/RearrangeTests.hs b/unittests/Futhark/IR/Prop/RearrangeTests.hs new file mode 100644 --- /dev/null +++ b/unittests/Futhark/IR/Prop/RearrangeTests.hs @@ -0,0 +1,55 @@ +module Futhark.IR.Prop.RearrangeTests + ( tests ) + where + +import Control.Applicative + +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck + +import Prelude + +import Futhark.IR.Prop.Rearrange + +tests :: TestTree +tests = testGroup "RearrangeTests" $ + isMapTransposeTests ++ + [isMapTransposeProp] + +isMapTransposeTests :: [TestTree] +isMapTransposeTests = + [ testCase (unwords ["isMapTranspose", show perm, "==", show dres]) $ + isMapTranspose perm @?= dres + | (perm, dres) <- [ ([0,1,4,5,2,3], Just (2,2,2)) + , ([1,0,4,5,2,3], Nothing) + , ([1,0], Just (0, 1, 1)) + , ([0,2,1], Just (1, 1, 1)) + , ([0,1,2], Nothing) + , ([1,0,2], Nothing) + ] + ] + +newtype Permutation = Permutation [Int] + deriving (Eq, Ord, Show) + +instance Arbitrary Permutation where + arbitrary = do + Positive n <- arbitrary + Permutation <$> shuffle [0..n-1] + +isMapTransposeProp :: TestTree +isMapTransposeProp = testProperty "isMapTranspose corresponds to a map of transpose" prop + where prop :: Permutation -> Bool + prop (Permutation perm) = + case isMapTranspose perm of + Nothing -> True + Just (r1, r2, r3) -> + and [r1 >= 0, + r2 > 0, + r3 > 0, + r1 + r2 + r3 == length perm, + let (mapped, notmapped) =splitAt r1 perm + (pretrans, posttrans) = splitAt r2 notmapped + in mapped ++ posttrans ++ pretrans == [0..length perm-1] + ] diff --git a/unittests/Futhark/IR/Prop/ReshapeTests.hs b/unittests/Futhark/IR/Prop/ReshapeTests.hs new file mode 100644 --- /dev/null +++ b/unittests/Futhark/IR/Prop/ReshapeTests.hs @@ -0,0 +1,93 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Futhark.IR.Prop.ReshapeTests + ( tests + ) + where + +import Control.Applicative + +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck + +import Prelude + +import Futhark.IR.Prop.Reshape +import Futhark.IR.Syntax +import Futhark.IR.Prop.Constants + +tests :: TestTree +tests = testGroup "ReshapeTests" $ + fuseReshapeTests ++ + informReshapeTests ++ + reshapeOuterTests ++ + reshapeInnerTests ++ + [ fuseReshapeProp + , informReshapeProp + ] + +fuseReshapeTests :: [TestTree] +fuseReshapeTests = + [ testCase (unwords ["fuseReshape ", show d1, show d2]) $ + fuseReshape (d1 :: ShapeChange Int) d2 @?= dres -- type signature to avoid warning + | (d1, d2, dres) <- [ ([DimCoercion 1], [DimNew 1], [DimCoercion 1]) + , ([DimNew 1], [DimCoercion 1], [DimNew 1]) + , ([DimCoercion 1, DimNew 2], [DimNew 1, DimNew 2], [DimCoercion 1, DimNew 2]) + , ([DimNew 1, DimNew 2], [DimCoercion 1, DimNew 2], [DimNew 1, DimNew 2]) + ] + ] + +informReshapeTests :: [TestTree] +informReshapeTests = + [ testCase (unwords ["informReshape ", show shape, show sc, show sc_res]) $ + informReshape (shape :: [Int]) sc @?= sc_res -- type signature to avoid warning + | (shape, sc, sc_res) <- + [ ([1, 2], [DimNew 1, DimNew 3], [DimCoercion 1, DimNew 3]) + , ([2, 2], [DimNew 1, DimNew 3], [DimNew 1, DimNew 3]) + ] + ] + +reshapeOuterTests :: [TestTree] +reshapeOuterTests = + [ testCase (unwords ["reshapeOuter", show sc, show n, show shape, "==", show sc_res]) $ + reshapeOuter (intShapeChange sc) n (intShape shape) @?= intShapeChange sc_res + | (sc, n, shape, sc_res) <- + [ ([DimNew 1], 1, [4, 3], [DimNew 1, DimCoercion 3]) + , ([DimNew 1], 2, [4, 3], [DimNew 1]) + , ([DimNew 2, DimNew 2], 1, [4, 3], [DimNew 2, DimNew 2, DimNew 3]) + , ([DimNew 2, DimNew 2], 2, [4, 3], [DimNew 2, DimNew 2]) + ] + ] + +reshapeInnerTests :: [TestTree] +reshapeInnerTests = + [ testCase (unwords ["reshapeInner", show sc, show n, show shape, "==", show sc_res]) $ + reshapeInner (intShapeChange sc) n (intShape shape) @?= intShapeChange sc_res + | (sc, n, shape, sc_res) <- + [ ([DimNew 1], 1, [4, 3], [DimCoercion 4, DimNew 1]) + , ([DimNew 1], 0, [4, 3], [DimNew 1]) + , ([DimNew 2, DimNew 2], 1, [4, 3], [DimNew 4, DimNew 2, DimNew 2]) + , ([DimNew 2, DimNew 2], 0, [4, 3], [DimNew 2, DimNew 2]) + ] + ] + +intShape :: [Int] -> Shape +intShape = Shape . map (intConst Int32 . toInteger) + +intShapeChange :: ShapeChange Int -> ShapeChange SubExp +intShapeChange = map (fmap $ intConst Int32 . toInteger) + +fuseReshapeProp :: TestTree +fuseReshapeProp = testProperty "fuseReshape result matches second argument" prop + where prop :: ShapeChange Int -> ShapeChange Int -> Bool + prop sc1 sc2 = map newDim (fuseReshape sc1 sc2) == map newDim sc2 + +informReshapeProp :: TestTree +informReshapeProp = testProperty "informReshape result matches second argument" prop + where prop :: [Int] -> ShapeChange Int -> Bool + prop sc1 sc2 = map newDim (informReshape sc1 sc2) == map newDim sc2 + +instance Arbitrary d => Arbitrary (DimChange d) where + arbitrary = oneof [ DimNew <$> arbitrary + , DimCoercion <$> arbitrary + ] diff --git a/unittests/Futhark/IR/PropTests.hs b/unittests/Futhark/IR/PropTests.hs new file mode 100644 --- /dev/null +++ b/unittests/Futhark/IR/PropTests.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Futhark.IR.PropTests + ( tests + ) +where + +import Test.Tasty + +import qualified Futhark.IR.Prop.ReshapeTests +import qualified Futhark.IR.Prop.RearrangeTests + +tests :: TestTree +tests = testGroup "PropTests" + [Futhark.IR.Prop.ReshapeTests.tests, + Futhark.IR.Prop.RearrangeTests.tests] diff --git a/unittests/Futhark/IR/Syntax/CoreTests.hs b/unittests/Futhark/IR/Syntax/CoreTests.hs new file mode 100644 --- /dev/null +++ b/unittests/Futhark/IR/Syntax/CoreTests.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Futhark.IR.Syntax.CoreTests + ( tests ) + where + +import Control.Applicative + +import Test.Tasty +import Test.Tasty.HUnit +import Test.QuickCheck + +import Prelude + +import Language.Futhark.CoreTests () +import Futhark.IR.PrimitiveTests() +import Futhark.IR.Syntax.Core +import Futhark.IR.Pretty () + +tests :: TestTree +tests = testGroup "Internal CoreTests" subShapeTests + +subShapeTests :: [TestTree] +subShapeTests = + [ shape [free 1, free 2] `isSubShapeOf` shape [free 1, free 2] + , shape [free 1, free 3] `isNotSubShapeOf` shape [free 1, free 2] + , shape [free 1] `isNotSubShapeOf` shape [free 1, free 2] + , shape [free 1, free 2] `isSubShapeOf` shape [free 1, Ext 3] + , shape [Ext 1, Ext 2] `isNotSubShapeOf` shape [Ext 1, Ext 1] + , shape [Ext 1, Ext 1] `isSubShapeOf` shape [Ext 1, Ext 2] + ] + where shape :: [ExtSize] -> ExtShape + shape = Shape + + free :: Int -> ExtSize + free = Free . Constant . IntValue . Int32Value . fromIntegral + + isSubShapeOf shape1 shape2 = + subShapeTest shape1 shape2 True + isNotSubShapeOf shape1 shape2 = + subShapeTest shape1 shape2 False + + subShapeTest :: ExtShape -> ExtShape -> Bool -> TestTree + subShapeTest shape1 shape2 expected = + testCase ("subshapeOf " ++ pretty shape1 ++ " " ++ + pretty shape2 ++ " == " ++ + show expected) $ + shape1 `subShapeOf` shape2 @?= expected + +instance Arbitrary NoUniqueness where + arbitrary = pure NoUniqueness + +instance (Arbitrary shape, Arbitrary u) => Arbitrary (TypeBase shape u) where + arbitrary = + oneof [ Prim <$> arbitrary + , Array <$> arbitrary <*> arbitrary <*> arbitrary + ] + +instance Arbitrary Ident where + arbitrary = Ident <$> arbitrary <*> arbitrary + +instance Arbitrary Rank where + arbitrary = Rank <$> elements [1..9] + +instance Arbitrary Shape where + arbitrary = Shape . map intconst <$> listOf1 (elements [1..9]) + where intconst = Constant . IntValue . Int32Value diff --git a/unittests/Futhark/IR/SyntaxTests.hs b/unittests/Futhark/IR/SyntaxTests.hs new file mode 100644 --- /dev/null +++ b/unittests/Futhark/IR/SyntaxTests.hs @@ -0,0 +1,7 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Futhark.IR.SyntaxTests + () +where + +-- There isn't anything to test in this module. At some point, maybe +-- we can put some Arbitrary instances here. diff --git a/unittests/Futhark/Optimise/AlgSimplifyTests.hs b/unittests/Futhark/Optimise/AlgSimplifyTests.hs --- a/unittests/Futhark/Optimise/AlgSimplifyTests.hs +++ b/unittests/Futhark/Optimise/AlgSimplifyTests.hs @@ -7,7 +7,7 @@ import Data.List (sort, mapAccumL) import qualified Data.Map.Strict as M -import Futhark.Representation.AST +import Futhark.IR import Futhark.Analysis.ScalExp import Futhark.Analysis.ScalExpTests (parseScalExp) import Futhark.Analysis.AlgSimplify diff --git a/unittests/Futhark/Representation/AST/Attributes/RearrangeTests.hs b/unittests/Futhark/Representation/AST/Attributes/RearrangeTests.hs deleted file mode 100644 --- a/unittests/Futhark/Representation/AST/Attributes/RearrangeTests.hs +++ /dev/null @@ -1,55 +0,0 @@ -module Futhark.Representation.AST.Attributes.RearrangeTests - ( tests ) - where - -import Control.Applicative - -import Test.Tasty -import Test.Tasty.HUnit -import Test.Tasty.QuickCheck - -import Prelude - -import Futhark.Representation.AST.Attributes.Rearrange - -tests :: TestTree -tests = testGroup "RearrangeTests" $ - isMapTransposeTests ++ - [isMapTransposeProp] - -isMapTransposeTests :: [TestTree] -isMapTransposeTests = - [ testCase (unwords ["isMapTranspose", show perm, "==", show dres]) $ - isMapTranspose perm @?= dres - | (perm, dres) <- [ ([0,1,4,5,2,3], Just (2,2,2)) - , ([1,0,4,5,2,3], Nothing) - , ([1,0], Just (0, 1, 1)) - , ([0,2,1], Just (1, 1, 1)) - , ([0,1,2], Nothing) - , ([1,0,2], Nothing) - ] - ] - -newtype Permutation = Permutation [Int] - deriving (Eq, Ord, Show) - -instance Arbitrary Permutation where - arbitrary = do - Positive n <- arbitrary - Permutation <$> shuffle [0..n-1] - -isMapTransposeProp :: TestTree -isMapTransposeProp = testProperty "isMapTranspose corresponds to a map of transpose" prop - where prop :: Permutation -> Bool - prop (Permutation perm) = - case isMapTranspose perm of - Nothing -> True - Just (r1, r2, r3) -> - and [r1 >= 0, - r2 > 0, - r3 > 0, - r1 + r2 + r3 == length perm, - let (mapped, notmapped) =splitAt r1 perm - (pretrans, posttrans) = splitAt r2 notmapped - in mapped ++ posttrans ++ pretrans == [0..length perm-1] - ] diff --git a/unittests/Futhark/Representation/AST/Attributes/ReshapeTests.hs b/unittests/Futhark/Representation/AST/Attributes/ReshapeTests.hs deleted file mode 100644 --- a/unittests/Futhark/Representation/AST/Attributes/ReshapeTests.hs +++ /dev/null @@ -1,93 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Futhark.Representation.AST.Attributes.ReshapeTests - ( tests - ) - where - -import Control.Applicative - -import Test.Tasty -import Test.Tasty.HUnit -import Test.Tasty.QuickCheck - -import Prelude - -import Futhark.Representation.AST.Attributes.Reshape -import Futhark.Representation.AST.Syntax -import Futhark.Representation.AST.Attributes.Constants - -tests :: TestTree -tests = testGroup "ReshapeTests" $ - fuseReshapeTests ++ - informReshapeTests ++ - reshapeOuterTests ++ - reshapeInnerTests ++ - [ fuseReshapeProp - , informReshapeProp - ] - -fuseReshapeTests :: [TestTree] -fuseReshapeTests = - [ testCase (unwords ["fuseReshape ", show d1, show d2]) $ - fuseReshape (d1 :: ShapeChange Int) d2 @?= dres -- type signature to avoid warning - | (d1, d2, dres) <- [ ([DimCoercion 1], [DimNew 1], [DimCoercion 1]) - , ([DimNew 1], [DimCoercion 1], [DimNew 1]) - , ([DimCoercion 1, DimNew 2], [DimNew 1, DimNew 2], [DimCoercion 1, DimNew 2]) - , ([DimNew 1, DimNew 2], [DimCoercion 1, DimNew 2], [DimNew 1, DimNew 2]) - ] - ] - -informReshapeTests :: [TestTree] -informReshapeTests = - [ testCase (unwords ["informReshape ", show shape, show sc, show sc_res]) $ - informReshape (shape :: [Int]) sc @?= sc_res -- type signature to avoid warning - | (shape, sc, sc_res) <- - [ ([1, 2], [DimNew 1, DimNew 3], [DimCoercion 1, DimNew 3]) - , ([2, 2], [DimNew 1, DimNew 3], [DimNew 1, DimNew 3]) - ] - ] - -reshapeOuterTests :: [TestTree] -reshapeOuterTests = - [ testCase (unwords ["reshapeOuter", show sc, show n, show shape, "==", show sc_res]) $ - reshapeOuter (intShapeChange sc) n (intShape shape) @?= intShapeChange sc_res - | (sc, n, shape, sc_res) <- - [ ([DimNew 1], 1, [4, 3], [DimNew 1, DimCoercion 3]) - , ([DimNew 1], 2, [4, 3], [DimNew 1]) - , ([DimNew 2, DimNew 2], 1, [4, 3], [DimNew 2, DimNew 2, DimNew 3]) - , ([DimNew 2, DimNew 2], 2, [4, 3], [DimNew 2, DimNew 2]) - ] - ] - -reshapeInnerTests :: [TestTree] -reshapeInnerTests = - [ testCase (unwords ["reshapeInner", show sc, show n, show shape, "==", show sc_res]) $ - reshapeInner (intShapeChange sc) n (intShape shape) @?= intShapeChange sc_res - | (sc, n, shape, sc_res) <- - [ ([DimNew 1], 1, [4, 3], [DimCoercion 4, DimNew 1]) - , ([DimNew 1], 0, [4, 3], [DimNew 1]) - , ([DimNew 2, DimNew 2], 1, [4, 3], [DimNew 4, DimNew 2, DimNew 2]) - , ([DimNew 2, DimNew 2], 0, [4, 3], [DimNew 2, DimNew 2]) - ] - ] - -intShape :: [Int] -> Shape -intShape = Shape . map (intConst Int32 . toInteger) - -intShapeChange :: ShapeChange Int -> ShapeChange SubExp -intShapeChange = map (fmap $ intConst Int32 . toInteger) - -fuseReshapeProp :: TestTree -fuseReshapeProp = testProperty "fuseReshape result matches second argument" prop - where prop :: ShapeChange Int -> ShapeChange Int -> Bool - prop sc1 sc2 = map newDim (fuseReshape sc1 sc2) == map newDim sc2 - -informReshapeProp :: TestTree -informReshapeProp = testProperty "informReshape result matches second argument" prop - where prop :: [Int] -> ShapeChange Int -> Bool - prop sc1 sc2 = map newDim (informReshape sc1 sc2) == map newDim sc2 - -instance Arbitrary d => Arbitrary (DimChange d) where - arbitrary = oneof [ DimNew <$> arbitrary - , DimCoercion <$> arbitrary - ] diff --git a/unittests/Futhark/Representation/AST/AttributesTests.hs b/unittests/Futhark/Representation/AST/AttributesTests.hs deleted file mode 100644 --- a/unittests/Futhark/Representation/AST/AttributesTests.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Futhark.Representation.AST.AttributesTests - ( tests - ) -where - -import Test.Tasty - -import qualified Futhark.Representation.AST.Attributes.ReshapeTests -import qualified Futhark.Representation.AST.Attributes.RearrangeTests - -tests :: TestTree -tests = testGroup "AttributesTests" - [Futhark.Representation.AST.Attributes.ReshapeTests.tests, - Futhark.Representation.AST.Attributes.RearrangeTests.tests] diff --git a/unittests/Futhark/Representation/AST/Syntax/CoreTests.hs b/unittests/Futhark/Representation/AST/Syntax/CoreTests.hs deleted file mode 100644 --- a/unittests/Futhark/Representation/AST/Syntax/CoreTests.hs +++ /dev/null @@ -1,67 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Futhark.Representation.AST.Syntax.CoreTests - ( tests ) - where - -import Control.Applicative - -import Test.Tasty -import Test.Tasty.HUnit -import Test.QuickCheck - -import Prelude - -import Language.Futhark.CoreTests () -import Futhark.Representation.PrimitiveTests() -import Futhark.Representation.AST.Syntax.Core -import Futhark.Representation.AST.Pretty () - -tests :: TestTree -tests = testGroup "Internal CoreTests" subShapeTests - -subShapeTests :: [TestTree] -subShapeTests = - [ shape [free 1, free 2] `isSubShapeOf` shape [free 1, free 2] - , shape [free 1, free 3] `isNotSubShapeOf` shape [free 1, free 2] - , shape [free 1] `isNotSubShapeOf` shape [free 1, free 2] - , shape [free 1, free 2] `isSubShapeOf` shape [free 1, Ext 3] - , shape [Ext 1, Ext 2] `isNotSubShapeOf` shape [Ext 1, Ext 1] - , shape [Ext 1, Ext 1] `isSubShapeOf` shape [Ext 1, Ext 2] - ] - where shape :: [ExtSize] -> ExtShape - shape = Shape - - free :: Int -> ExtSize - free = Free . Constant . IntValue . Int32Value . fromIntegral - - isSubShapeOf shape1 shape2 = - subShapeTest shape1 shape2 True - isNotSubShapeOf shape1 shape2 = - subShapeTest shape1 shape2 False - - subShapeTest :: ExtShape -> ExtShape -> Bool -> TestTree - subShapeTest shape1 shape2 expected = - testCase ("subshapeOf " ++ pretty shape1 ++ " " ++ - pretty shape2 ++ " == " ++ - show expected) $ - shape1 `subShapeOf` shape2 @?= expected - -instance Arbitrary NoUniqueness where - arbitrary = pure NoUniqueness - -instance (Arbitrary shape, Arbitrary u) => Arbitrary (TypeBase shape u) where - arbitrary = - oneof [ Prim <$> arbitrary - , Array <$> arbitrary <*> arbitrary <*> arbitrary - ] - -instance Arbitrary Ident where - arbitrary = Ident <$> arbitrary <*> arbitrary - -instance Arbitrary Rank where - arbitrary = Rank <$> elements [1..9] - -instance Arbitrary Shape where - arbitrary = Shape . map intconst <$> listOf1 (elements [1..9]) - where intconst = Constant . IntValue . Int32Value diff --git a/unittests/Futhark/Representation/AST/SyntaxTests.hs b/unittests/Futhark/Representation/AST/SyntaxTests.hs deleted file mode 100644 --- a/unittests/Futhark/Representation/AST/SyntaxTests.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Futhark.Representation.AST.SyntaxTests - () -where - --- There isn't anything to test in this module. At some point, maybe --- we can put some Arbitrary instances here. diff --git a/unittests/Futhark/Representation/Mem/IxFun/Alg.hs b/unittests/Futhark/Representation/Mem/IxFun/Alg.hs deleted file mode 100644 --- a/unittests/Futhark/Representation/Mem/IxFun/Alg.hs +++ /dev/null @@ -1,153 +0,0 @@ --- | A simple index operation representation. Every operation corresponds to a --- constructor. -module Futhark.Representation.Mem.IxFun.Alg - ( IxFun(..) - , iota - , offsetIndex - , permute - , rotate - , reshape - , slice - , rebase - , repeat - , shape - , index - ) -where - -import Prelude hiding (repeat, mod) - -import Futhark.Representation.AST.Syntax - (ShapeChange, DimChange(..), Slice, sliceDims, DimIndex(..), unitSlice) -import Futhark.Representation.AST.Attributes -import Futhark.Representation.AST.Pretty () -import Futhark.Util.IntegralExp -import Futhark.Util.Pretty - -type Shape num = [num] -type Indices num = [num] -type Permutation = [Int] - -data IxFun num = Direct (Shape num) - | Permute (IxFun num) Permutation - | Rotate (IxFun num) (Indices num) - | Index (IxFun num) (Slice num) - | Reshape (IxFun num) (ShapeChange num) - | Repeat (IxFun num) [Shape num] (Shape num) - | OffsetIndex (IxFun num) num - | Rebase (IxFun num) (IxFun num) - deriving (Eq, Show) - -instance Pretty num => Pretty (IxFun num) where - ppr (Direct dims) = - text "Direct" <> parens (commasep $ map ppr dims) - ppr (Permute fun perm) = ppr fun <> ppr perm - ppr (Rotate fun offsets) = ppr fun <> brackets (commasep $ map ((text "+" <>) . ppr) offsets) - ppr (Index fun is) = ppr fun <> brackets (commasep $ map ppr is) - ppr (Reshape fun oldshape) = - ppr fun <> text "->reshape" <> - parens (commasep (map ppr oldshape)) - ppr (Repeat fun outer_shapes inner_shape) = - ppr fun <> text "->repeat" <> parens (commasep (map ppr $ outer_shapes++ [inner_shape])) - ppr (OffsetIndex fun i) = - ppr fun <> text "->offset_index" <> parens (ppr i) - ppr (Rebase new_base fun) = - text "rebase(" <> ppr new_base <> text ", " <> ppr fun <> text ")" - - -iota :: Shape num -> IxFun num -iota = Direct - -offsetIndex :: IxFun num -> num -> IxFun num -offsetIndex = OffsetIndex - -permute :: IxFun num -> Permutation -> IxFun num -permute = Permute - -rotate :: IxFun num -> Indices num -> IxFun num -rotate = Rotate - -repeat :: IxFun num -> [Shape num] -> Shape num -> IxFun num -repeat = Repeat - -slice :: IxFun num -> Slice num -> IxFun num -slice = Index - -rebase :: IxFun num -> IxFun num -> IxFun num -rebase = Rebase - -reshape :: IxFun num -> ShapeChange num -> IxFun num -reshape = Reshape - -shape :: IntegralExp num => - IxFun num -> Shape num -shape (Direct dims) = - dims -shape (Permute ixfun perm) = - rearrangeShape perm $ shape ixfun -shape (Rotate ixfun _) = - shape ixfun -shape (Index _ how) = - sliceDims how -shape (Reshape _ dims) = - map newDim dims -shape (Repeat ixfun outer_shapes inner_shape) = - concat (zipWith repeated outer_shapes (shape ixfun)) ++ inner_shape - where repeated outer_ds d = outer_ds ++ [d] -shape (OffsetIndex ixfun _) = - shape ixfun -shape (Rebase _ ixfun) = - shape ixfun - -index :: (IntegralExp num, Eq num) => - IxFun num -> Indices num -> num -index (Direct dims) is = - sum $ zipWith (*) is slicesizes - where slicesizes = drop 1 $ sliceSizes dims -index (Permute fun perm) is_new = - index fun is_old - where is_old = rearrangeShape (rearrangeInverse perm) is_new -index (Rotate fun offsets) is = - index fun $ zipWith mod (zipWith (+) is offsets) dims - where dims = shape fun -index (Index fun js) is = - index fun (adjust js is) - where adjust (DimFix j:js') is' = j : adjust js' is' - adjust (DimSlice j _ s:js') (i:is') = j + i * s : adjust js' is' - adjust _ _ = [] -index (Reshape fun newshape) is = - let new_indices = reshapeIndex (shape fun) (newDims newshape) is - in index fun new_indices -index (Repeat fun outer_shapes _) is = - -- Discard those indices that are just repeats. It is intentional - -- that we cut off those indices that correspond to the innermost - -- repeated dimensions. - index fun is' - where flags dims = replicate (length dims) True ++ [False] - is' = map snd $ filter (not . fst) $ zip (concatMap flags outer_shapes) is -index (OffsetIndex fun i) is = - case shape fun of - d : ds -> - index (Index fun (DimSlice i (d-i) 1 : map (unitSlice 0) ds)) is - [] -> error "index: OffsetIndex: underlying index function has rank zero" -index (Rebase new_base fun) is = - let fun' = case fun of - Direct old_shape -> - if old_shape == shape new_base - then new_base - else reshape new_base $ map DimCoercion old_shape - Permute ixfun perm -> - permute (rebase new_base ixfun) perm - Rotate ixfun offsets -> - rotate (rebase new_base ixfun) offsets - Index ixfun iis -> - slice (rebase new_base ixfun) iis - Reshape ixfun new_shape -> - reshape (rebase new_base ixfun) new_shape - Repeat ixfun outer_shapes inner_shape -> - repeat (rebase new_base ixfun) outer_shapes inner_shape - OffsetIndex ixfun s -> - offsetIndex (rebase new_base ixfun) s - r@Rebase{} -> - r - in index fun' is diff --git a/unittests/Futhark/Representation/Mem/IxFunTests.hs b/unittests/Futhark/Representation/Mem/IxFunTests.hs deleted file mode 100644 --- a/unittests/Futhark/Representation/Mem/IxFunTests.hs +++ /dev/null @@ -1,371 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Futhark.Representation.Mem.IxFunTests - ( tests - ) -where - -import Prelude hiding (span, repeat) -import qualified Prelude as P -import qualified Data.List as DL - -import Test.Tasty -import Test.Tasty.HUnit - -import Futhark.Representation.AST.Syntax -import Futhark.Representation.AST.Syntax.Core() -import qualified Futhark.Util.Pretty as PR -import qualified Futhark.Util.IntegralExp as IE -import qualified Futhark.Representation.Mem.IxFun as IxFunLMAD -import qualified Futhark.Representation.Mem.IxFun.Alg as IxFunAlg - -import qualified Futhark.Representation.Mem.IxFunWrapper as IxFunWrap -import Futhark.Representation.Mem.IxFunWrapper - - -instance IE.IntegralExp Int where - quot = P.quot - rem = P.rem - div = P.div - mod = P.mod - sgn = Just . P.signum - - fromInt8 = fromInteger . toInteger - fromInt16 = fromInteger . toInteger - fromInt32 = fromInteger . toInteger - fromInt64 = fromInteger . toInteger - -allPoints :: [Int] -> [[Int]] -allPoints dims = - let total = product dims - strides = drop 1 $ DL.reverse $ scanl (*) 1 $ DL.reverse dims - in map (unflatInd strides) [0..total-1] - where unflatInd :: [Int] -> Int -> [Int] - unflatInd strides x = fst $ - foldl (\(res, acc) span -> - (res ++ [acc `P.div` span], acc `P.mod` span)) - ([], x) strides - -compareIxFuns :: IxFunLMAD.IxFun Int -> IxFunAlg.IxFun Int -> Assertion -compareIxFuns ixfunLMAD ixfunAlg = - let lmadShape = IxFunLMAD.shape ixfunLMAD - algShape = IxFunAlg.shape ixfunAlg - points = allPoints lmadShape - resLMAD = map (IxFunLMAD.index ixfunLMAD) points - resAlg = map (IxFunAlg.index ixfunAlg) points - errorMessage = "lmad ixfun: " ++ PR.pretty ixfunLMAD ++ "\n" ++ - "alg ixfun: " ++ PR.pretty ixfunAlg ++ "\n" ++ - "lmad shape: " ++ show lmadShape ++ "\n" ++ - "alg shape: " ++ show algShape ++ "\n" ++ - "lmad points length: " ++ show (length resLMAD) ++ "\n" ++ - "alg points length: " ++ show (length resAlg) ++ "\n" ++ - "lmad points: " ++ show resLMAD ++ "\n" ++ - "alg points: " ++ show resAlg - in (lmadShape == algShape && resLMAD == resAlg) @? errorMessage - -compareOps :: IxFunWrap.IxFun Int -> Assertion -compareOps (ixfunLMAD, ixfunAlg) = compareIxFuns ixfunLMAD ixfunAlg - --- XXX: Clean this up. -n :: Int -n = 19 -slice3 :: [DimIndex Int] -slice3 = [ DimSlice 2 (n `P.div` 3) 3 - , DimFix (n `P.div` 2) - , DimSlice 1 (n `P.div` 2) 2 - ] - - --- Actual tests. -tests :: TestTree -tests = testGroup "IxFunTests" - $ concat - [ test_iota - , test_slice_iota - , test_reshape_slice_iota1 - , test_permute_slice_iota - , test_repeat_slice_iota - , test_rotate_rotate_permute_slice_iota - , test_slice_rotate_permute_slice_iota1 - , test_slice_rotate_permute_slice_iota2 - , test_slice_rotate_permute_slice_iota3 - , test_permute_rotate_slice_permute_slice_iota - , test_reshape_rotate_iota - , test_reshape_permute_iota - , test_reshape_slice_iota2 - , test_reshape_slice_iota3 - , test_complex1 - , test_complex2 - , test_complex3 - , test_rebase1 - , test_rebase2 - , test_rebase3 - , test_rebase4_5 - , test_rebase6 - ] - -singleton :: TestTree -> [TestTree] -singleton = (: []) - -test_iota :: [TestTree] -test_iota = singleton $ testCase "iota" $ compareOps $ - iota [n] - -test_slice_iota :: [TestTree] -test_slice_iota = singleton $ testCase "slice . iota" $ compareOps $ - slice (iota [n, n, n]) slice3 - -test_reshape_slice_iota1 :: [TestTree] -test_reshape_slice_iota1 = singleton $ testCase "reshape . slice . iota 1" $ compareOps $ - reshape (slice (iota [n, n, n]) slice3) - [DimNew (n `P.div` 2), DimNew (n `P.div` 3)] - -test_permute_slice_iota :: [TestTree] -test_permute_slice_iota = singleton $ testCase "permute . slice . iota" $ compareOps $ - permute (slice (iota [n, n, n]) slice3) [1, 0] - -test_repeat_slice_iota :: [TestTree] -test_repeat_slice_iota = singleton $ testCase "repeat . slice . iota" $ compareOps $ - repeat (slice (iota [n, n, n]) slice3) [[2, 3], [3, 2]] [4, 4] - -test_rotate_rotate_permute_slice_iota :: [TestTree] -test_rotate_rotate_permute_slice_iota = - singleton $ testCase "rotate . rotate . permute . slice . iota" $ compareOps $ - let ixfun = permute (slice (iota [n, n, n]) slice3) [1, 0] - in rotate (rotate ixfun [2, 1]) [1, 2] - -test_slice_rotate_permute_slice_iota1 :: [TestTree] -test_slice_rotate_permute_slice_iota1 = - singleton $ testCase "slice . rotate . permute . slice . iota 1" $ compareOps $ - let slice2 = [ DimSlice 0 n 1 - , DimSlice 1 (n `P.div` 2) 2 - , DimSlice 0 n 1 - ] - slice13 = [ DimSlice 2 (n `P.div` 3) 3 - , DimSlice 0 (n `P.div` 2) 1 - , DimSlice 1 (n `P.div` 2) 2 - ] - ixfun = permute (slice (iota [n, n, n]) slice2) [2, 1, 0] - ixfun' = slice (rotate ixfun [3, 1, 2]) slice13 - in ixfun' - -test_slice_rotate_permute_slice_iota2 :: [TestTree] -test_slice_rotate_permute_slice_iota2 = - singleton $ testCase "slice . rotate . permute . slice . iota 2" $ compareOps $ - let slice2 = [ DimSlice 0 (n `P.div` 2) 1 - , DimFix (n `P.div` 2) - , DimSlice 0 (n `P.div` 3) 1 - ] - slice13 = [ DimSlice 2 (n `P.div` 3) 3 - , DimSlice 0 n 1 - , DimSlice 1 (n `P.div` 2) 2 - ] - ixfun = permute (slice (iota [n, n, n]) slice13) [2, 1, 0] - ixfun' = slice (rotate ixfun [3, 1, 2]) slice2 - in ixfun' - -test_slice_rotate_permute_slice_iota3 :: [TestTree] -test_slice_rotate_permute_slice_iota3 = - singleton $ testCase "slice . rotate . permute . slice . iota 3" $ compareOps $ - -- full-slice of (-1) stride - let ixfun = permute (slice (iota [n, n, n]) slice3) [1, 0] - ixfun' = rotate ixfun [2, 1] - - (n1, m1) = case IxFunLMAD.shape (fst ixfun') of - [a, b] -> (a, b) - _ -> error "expecting 2 dimensions at this point!" - negslice = [DimSlice 0 n1 1, DimSlice (m1 - 1) m1 (-1)] - ixfun'' = rotate (slice ixfun' negslice) [1,2] - in ixfun'' - -test_permute_rotate_slice_permute_slice_iota :: [TestTree] -test_permute_rotate_slice_permute_slice_iota = - singleton $ testCase "permute . rotate . slice . permute . slice . iota" $ compareOps $ - -- contiguousness - let slice33 = [ DimFix (n `P.div` 2) - , DimSlice (n - 1) (n `P.div` 3) (-1) - , DimSlice 0 n 1 - ] - ixfun = permute (slice (iota [n, n, n]) slice33) [1, 0] - m = n `P.div` 3 - slice1 = [DimSlice (n - 1) n (-1), DimSlice 2 (m - 2) 1] - ixfun' = permute (rotate (slice ixfun slice1) [1, 2]) [1, 0] - in ixfun' - -test_reshape_rotate_iota :: [TestTree] -test_reshape_rotate_iota = - -- negative reshape test - singleton $ testCase "reshape . rotate . iota" $ compareOps $ - let newdims = [DimNew (n * n), DimCoercion n] - in reshape (rotate (iota [n, n, n]) [1, 0, 0]) newdims - -test_reshape_permute_iota :: [TestTree] -test_reshape_permute_iota = - -- negative reshape test - singleton $ testCase "reshape . permute . iota" $ compareOps $ - let newdims = [DimNew (n * n), DimCoercion n] - in reshape (permute (iota [n, n, n]) [1, 2, 0]) newdims - -test_reshape_slice_iota2 :: [TestTree] -test_reshape_slice_iota2 = - -- negative reshape test - singleton $ testCase "reshape . slice . iota 2" $ compareOps $ - let newdims = [DimNew (n*n), DimCoercion n] - slc = [ DimFix (n `P.div` 2) - , DimSlice (n-1) n (-1) - , DimSlice 0 n 1 - , DimSlice (n-1) n (-1) - ] - in reshape (slice (iota [n, n, n, n]) slc) newdims - -test_reshape_slice_iota3 :: [TestTree] -test_reshape_slice_iota3 = - -- negative reshape test - singleton $ testCase "reshape . slice . iota 3" $ compareOps $ - let newdims = [DimNew (n*n), DimCoercion n] - slc = [ DimFix (n `P.div` 2) - , DimSlice 0 n 1 - , DimSlice 0 (n `P.div` 2) 1 - , DimSlice 0 n 1 - ] - in reshape (slice (iota [n, n, n, n]) slc) newdims - -test_complex1 :: [TestTree] -test_complex1 = - singleton $ testCase "reshape . permute . rotate . slice . permute . slice . iota 1" $ compareOps $ - let newdims = [ DimCoercion n - , DimCoercion n - , DimNew n - , DimCoercion ((n `P.div` 3) - 2) - ] - slice33 = [ DimSlice (n-1) (n `P.div` 3) (-1) - , DimSlice (n-1) n (-1) - , DimSlice (n-1) n (-1) - , DimSlice 0 n 1 - ] - ixfun = permute (slice (iota [n, n, n, n, n]) slice33) [3, 1, 2, 0] - m = n `P.div` 3 - slice1 = [DimSlice 0 n 1, DimSlice (n-1) n (-1), DimSlice (n-1) n (-1), DimSlice 1 (m-2) (-1)] - ixfun' = reshape (rotate (slice ixfun slice1) [1, 2, 3, 4]) newdims - in ixfun' - -test_complex2 :: [TestTree] -test_complex2 = - singleton $ testCase "reshape . permute . rotate . slice . permute . slice . iota 2" $ compareOps $ - let newdims = [ DimCoercion n - , DimNew (n*n) - , DimCoercion ((n `P.div` 3) - 2)] - slc2 = [ DimFix (n `P.div` 2) - , DimSlice (n-1) (n `P.div` 3) (-1) - , DimSlice (n-1) n (-1) - , DimSlice (n-1) n (-1) - , DimSlice 0 n 1 - ] - ixfun = permute (slice (iota [n, n, n, n, n]) slc2) [3, 1, 2, 0] - m = n `P.div` 3 - slice1 = [DimSlice 0 n 1, DimSlice (n-1) n (-1), DimSlice (n-1) n (-1), DimSlice 1 (m-2) (-1)] - ixfun' = reshape (rotate (slice ixfun slice1) [1, 0, 0, 2]) newdims - in ixfun' - -test_complex3 :: [TestTree] -test_complex3 = - singleton $ testCase "reshape . permute . rotate . slice . permute . slice . iota 3" $ compareOps $ - let newdims = [ DimCoercion 1 - , DimCoercion n - , DimNew (n*n) - , DimCoercion 2 - , DimCoercion ((n `P.div` 3) - 2) - ] - slc3 = [ DimFix (n `P.div` 2) - , DimSlice (n-1) (n `P.div` 3) (-1) - , DimSlice (n-1) n (-1) - , DimSlice (n-1) n (-1) - , DimSlice 0 n 1 - ] - ixfun = permute (slice (iota [n, n, n, n, n]) slc3) [3, 1, 2, 0] - m = n `P.div` 3 - slice1 = [DimSlice 0 n 1, DimSlice (n-1) n (-1), DimSlice (n-1) n (-1), DimSlice 1 (m-2) (-1)] - repeats = [[1],[],[],[2]] - ixfun' = reshape (repeat (rotate (slice ixfun slice1) [1, 0, 0, 2]) repeats []) newdims - in ixfun' - -test_rebase1 :: [TestTree] -test_rebase1 = - singleton $ testCase "rebase 1" $ compareOps $ - let slice_base = [ DimFix (n `P.div` 2) - , DimSlice 2 (n-2) 1 - , DimSlice 3 (n-3) 1 - ] - ixfn_base = rotate (permute (slice (iota [n, n, n]) slice_base) [1, 0]) [2, 1] - ixfn_orig = rotate (permute (iota [n-3, n-2]) [1, 0]) [1, 2] - ixfn_rebase = rebase ixfn_base ixfn_orig - in ixfn_rebase - -test_rebase2 :: [TestTree] -test_rebase2 = - singleton $ testCase "rebase 2" $ compareOps $ - let slice_base = [ DimFix (n `P.div` 2) - , DimSlice (n-1) (n-2) (-1) - , DimSlice (n-1) (n-3) (-1) - ] - slice_orig = [ DimSlice (n-4) (n-3) (-1) - , DimSlice (n-3) (n-2) (-1) - ] - ixfn_base = rotate (permute (slice (iota [n, n, n]) slice_base) [1, 0]) [2, 1] - ixfn_orig = rotate (permute (slice (iota [n-3, n-2]) slice_orig) [1, 0]) [1, 2] - ixfn_rebase = rebase ixfn_base ixfn_orig - in ixfn_rebase - -test_rebase3 :: [TestTree] -test_rebase3 = - singleton $ testCase "rebase full orig but not monotonic" $ compareOps $ - let n2 = (n-2) `P.div` 3 - n3 = (n-3) `P.div` 2 - slice_base = [ DimFix (n `P.div` 2) - , DimSlice (n-1) n2 (-3) - , DimSlice (n-1) n3 (-2) - ] - slice_orig = [ DimSlice (n3-1) n3 (-1) - , DimSlice (n2-1) n2 (-1) - ] - ixfn_base = rotate (permute (slice (iota [n, n, n]) slice_base) [1, 0]) [2, 1] - ixfn_orig = rotate (permute (slice (iota [n3, n2]) slice_orig) [1, 0]) [1, 2] - ixfn_rebase = rebase ixfn_base ixfn_orig - in ixfn_rebase - -test_rebase4_5 :: [TestTree] -test_rebase4_5 = - let n2 = (n-2) `P.div` 3 - n3 = (n-3) `P.div` 2 - slice_base = [ DimFix (n `P.div` 2) - , DimSlice (n-1) n2 (-3) - , DimSlice 3 n3 2 - ] - slice_orig = [ DimSlice (n3-1) n3 (-1) - , DimSlice 0 n2 1 - ] - ixfn_base = rotate (permute (slice (iota [n, n, n]) slice_base) [1, 0]) [2, 1] - ixfn_orig = rotate (permute (slice (iota [n3, n2]) slice_orig) [1, 0]) [1, 2] - in [ testCase "rebase mixed monotonicities" $ compareOps $ - rebase ixfn_base ixfn_orig - - , testCase "rebase repetitions and mixed monotonicities 1" $ compareOps $ - let ixfn_orig' = repeat ixfn_orig [[2, 2], [3, 3]] [2, 3] - in rebase ixfn_base ixfn_orig' - ] - -test_rebase6 :: [TestTree] -test_rebase6 = - singleton $ testCase "rebase repetitions and mixed monotonicities 2" $ compareOps $ - let n2 = (n-2) `P.div` 3 - n3 = (n-3) `P.div` 2 - slice_base = [ DimFix (n `P.div` 2) - , DimSlice (n-1) n2 (-3) - ] - slice_orig = [ DimSlice (n3-1) n3 (-1) - , DimSlice 0 n2 1 - ] - ixfn_base = permute (repeat (rotate (slice (iota [n, n]) slice_base) [1]) [[], []] [n3]) [1, 0] - ixfn_orig = rotate (permute (slice (iota [n3, n2]) slice_orig) [1, 0]) [1, 2] - ixfn_orig' = repeat ixfn_orig [[2, 2],[3, 3]] [2, 3] - ixfn_rebase = rebase ixfn_base ixfn_orig' - in ixfn_rebase diff --git a/unittests/Futhark/Representation/Mem/IxFunWrapper.hs b/unittests/Futhark/Representation/Mem/IxFunWrapper.hs deleted file mode 100644 --- a/unittests/Futhark/Representation/Mem/IxFunWrapper.hs +++ /dev/null @@ -1,55 +0,0 @@ --- | Perform index function operations in both algebraic and LMAD --- representations. -module Futhark.Representation.Mem.IxFunWrapper - ( IxFun - , iota - , permute - , rotate - , reshape - , slice - , rebase - , repeat - ) -where - -import Prelude hiding (repeat) - -import Futhark.Util.IntegralExp -import Futhark.Representation.AST.Syntax (ShapeChange, Slice) -import qualified Futhark.Representation.Mem.IxFun as I -import qualified Futhark.Representation.Mem.IxFun.Alg as IA - - -type Shape num = [num] -type Indices num = [num] -type Permutation = [Int] - -type IxFun num = (I.IxFun num, IA.IxFun num) - -iota :: IntegralExp num => - Shape num -> IxFun num -iota x = (I.iota x, IA.iota x) - -permute :: IntegralExp num => - IxFun num -> Permutation -> IxFun num -permute (l, a) x = (I.permute l x, IA.permute a x) - -rotate :: (Eq num, IntegralExp num) => - IxFun num -> Indices num -> IxFun num -rotate (l, a) x = (I.rotate l x, IA.rotate a x) - -repeat :: (Eq num, IntegralExp num) => - IxFun num -> [Shape num] -> Shape num -> IxFun num -repeat (l, a) x y = (I.repeat l x y, IA.repeat a x y) - -reshape :: (Eq num, IntegralExp num) => - IxFun num -> ShapeChange num -> IxFun num -reshape (l, a) x = (I.reshape l x, IA.reshape a x) - -slice :: (Eq num, IntegralExp num) => - IxFun num -> Slice num -> IxFun num -slice (l, a) x = (I.slice l x, IA.slice a x) - -rebase :: (Eq num, IntegralExp num) => - IxFun num -> IxFun num -> IxFun num -rebase (l, a) (l1, a1) = (I.rebase l l1, IA.rebase a a1) diff --git a/unittests/Futhark/Representation/PrimitiveTests.hs b/unittests/Futhark/Representation/PrimitiveTests.hs deleted file mode 100644 --- a/unittests/Futhark/Representation/PrimitiveTests.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Futhark.Representation.PrimitiveTests - ( tests - , arbitraryPrimValOfType - ) - where - -import Control.Applicative - -import Test.QuickCheck -import Test.Tasty -import Test.Tasty.HUnit - -import Prelude - -import Futhark.Representation.Primitive - -tests :: TestTree -tests = testGroup "PrimitiveTests" propPrimValuesHaveRightType - -propPrimValuesHaveRightType :: [TestTree] -propPrimValuesHaveRightType = [ testCase (show t ++ " has blank of right type") $ - primValueType (blankPrimValue t) @?= t - | t <- [minBound..maxBound] - ] - -instance Arbitrary IntType where - arbitrary = elements [minBound..maxBound] - -instance Arbitrary FloatType where - arbitrary = elements [minBound..maxBound] - -instance Arbitrary PrimType where - arbitrary = elements [minBound..maxBound] - -instance Arbitrary IntValue where - arbitrary = oneof [ Int8Value <$> arbitrary - , Int16Value <$> arbitrary - , Int32Value <$> arbitrary - , Int64Value <$> arbitrary ] - -instance Arbitrary FloatValue where - arbitrary = oneof [ Float32Value <$> arbitrary - , Float64Value <$> arbitrary ] - -instance Arbitrary PrimValue where - arbitrary = oneof [ IntValue <$> arbitrary - , FloatValue <$> arbitrary - , BoolValue <$> arbitrary - , pure Checked - ] - -arbitraryPrimValOfType :: PrimType -> Gen PrimValue -arbitraryPrimValOfType (IntType Int8) = IntValue . Int8Value <$> arbitrary -arbitraryPrimValOfType (IntType Int16) = IntValue . Int16Value <$> arbitrary -arbitraryPrimValOfType (IntType Int32) = IntValue . Int32Value <$> arbitrary -arbitraryPrimValOfType (IntType Int64) = IntValue . Int64Value <$> arbitrary -arbitraryPrimValOfType (FloatType Float32) = FloatValue . Float32Value <$> arbitrary -arbitraryPrimValOfType (FloatType Float64) = FloatValue . Float32Value <$> arbitrary -arbitraryPrimValOfType Bool = BoolValue <$> arbitrary -arbitraryPrimValOfType Cert = return Checked diff --git a/unittests/Language/Futhark/CoreTests.hs b/unittests/Language/Futhark/CoreTests.hs --- a/unittests/Language/Futhark/CoreTests.hs +++ b/unittests/Language/Futhark/CoreTests.hs @@ -6,7 +6,7 @@ import Test.QuickCheck import Language.Futhark.Core -import Futhark.Representation.PrimitiveTests() +import Futhark.IR.PrimitiveTests() instance Arbitrary Name where arbitrary = nameFromString <$> listOf1 (elements ['a'..'z']) diff --git a/unittests/Language/Futhark/SyntaxTests.hs b/unittests/Language/Futhark/SyntaxTests.hs --- a/unittests/Language/Futhark/SyntaxTests.hs +++ b/unittests/Language/Futhark/SyntaxTests.hs @@ -12,7 +12,7 @@ import Language.Futhark.Syntax -import Futhark.Representation.PrimitiveTests() +import Futhark.IR.PrimitiveTests() tests :: TestTree tests = testGroup "Source SyntaxTests" [] diff --git a/unittests/futhark_tests.hs b/unittests/futhark_tests.hs --- a/unittests/futhark_tests.hs +++ b/unittests/futhark_tests.hs @@ -2,12 +2,12 @@ import qualified Language.Futhark.SyntaxTests import qualified Futhark.BenchTests -import qualified Futhark.Representation.AST.Syntax.CoreTests -import qualified Futhark.Representation.AST.AttributesTests -import qualified Futhark.Representation.Mem.IxFunTests +import qualified Futhark.IR.Syntax.CoreTests +import qualified Futhark.IR.PropTests +import qualified Futhark.IR.Mem.IxFunTests import qualified Futhark.Optimise.AlgSimplifyTests import qualified Futhark.Pkg.SolveTests -import qualified Futhark.Representation.PrimitiveTests +import qualified Futhark.IR.PrimitiveTests import qualified Futhark.Analysis.ScalExpTests import Test.Tasty @@ -17,12 +17,12 @@ testGroup "" [ Language.Futhark.SyntaxTests.tests , Futhark.BenchTests.tests - , Futhark.Representation.AST.AttributesTests.tests + , Futhark.IR.PropTests.tests , Futhark.Optimise.AlgSimplifyTests.tests - , Futhark.Representation.AST.Syntax.CoreTests.tests + , Futhark.IR.Syntax.CoreTests.tests , Futhark.Pkg.SolveTests.tests - , Futhark.Representation.Mem.IxFunTests.tests - , Futhark.Representation.PrimitiveTests.tests + , Futhark.IR.Mem.IxFunTests.tests + , Futhark.IR.PrimitiveTests.tests , Futhark.Analysis.ScalExpTests.tests ]