futhark 0.7.4 → 0.8.1
raw patch · 75 files changed
+4306/−2970 lines, 75 files
Files
- futhark.cabal +70/−68
- rts/c/opencl.h +8/−5
- rts/csharp/opencl.cs +1/−4
- rts/python/opencl.py +1/−3
- rts/python/values.py +6/−3
- src/Futhark/Analysis/Metrics.hs +0/−1
- src/Futhark/Analysis/PrimExp.hs +45/−0
- src/Futhark/Analysis/SymbolTable.hs +38/−3
- src/Futhark/CodeGen/Backends/COpenCL.hs +12/−2
- src/Futhark/CodeGen/Backends/COpenCL/Boilerplate.hs +0/−3
- src/Futhark/CodeGen/Backends/CSOpenCL/Boilerplate.hs +0/−1
- src/Futhark/CodeGen/Backends/GenericC.hs +1/−1
- src/Futhark/CodeGen/ImpCode.hs +1/−1
- src/Futhark/CodeGen/ImpCode/Kernels.hs +20/−27
- src/Futhark/CodeGen/ImpCode/OpenCL.hs +0/−5
- src/Futhark/CodeGen/ImpGen.hs +393/−443
- src/Futhark/CodeGen/ImpGen/Kernels.hs +1299/−1340
- src/Futhark/CodeGen/ImpGen/Kernels/ToOpenCL.hs +10/−246
- src/Futhark/CodeGen/ImpGen/Kernels/Transpose.hs +277/−0
- src/Futhark/CodeGen/OpenCL/Kernels.hs +0/−175
- src/Futhark/Compiler/CLI.hs +6/−3
- src/Futhark/Compiler/Program.hs +3/−1
- src/Futhark/Doc/Generator.hs +14/−6
- src/Futhark/Doc/Html.hs +5/−0
- src/Futhark/Internalise.hs +116/−52
- src/Futhark/Internalise/Bindings.hs +2/−0
- src/Futhark/Internalise/Defunctionalise.hs +28/−1
- src/Futhark/Internalise/Defunctorise.hs +4/−1
- src/Futhark/Internalise/Monomorphise.hs +19/−7
- src/Futhark/Internalise/TypesValues.hs +3/−0
- src/Futhark/Optimise/MemoryBlockMerging/Liveness/FirstUse.hs +0/−1
- src/Futhark/Optimise/Simplify/Engine.hs +11/−7
- src/Futhark/Optimise/Simplify/Rules.hs +22/−3
- src/Futhark/Optimise/TileLoops.hs +15/−10
- src/Futhark/Optimise/TileLoops/RegTiling3D.hs +739/−0
- src/Futhark/Pass/ExplicitAllocations.hs +36/−29
- src/Futhark/Pass/ExtractKernels/Segmented.hs +1/−1
- src/Futhark/Pass/KernelBabysitting.hs +43/−17
- src/Futhark/Passes.hs +1/−0
- src/Futhark/Representation/AST/Attributes.hs +6/−0
- src/Futhark/Representation/AST/Attributes/Aliases.hs +0/−2
- src/Futhark/Representation/AST/Attributes/Ranges.hs +0/−2
- src/Futhark/Representation/AST/Attributes/TypeOf.hs +0/−4
- src/Futhark/Representation/AST/Pretty.hs +0/−3
- src/Futhark/Representation/AST/Syntax.hs +0/−5
- src/Futhark/Representation/AST/Syntax/Core.hs +4/−4
- src/Futhark/Representation/AST/Traversals.hs +0/−3
- src/Futhark/Representation/ExplicitMemory.hs +8/−10
- src/Futhark/Representation/Kernels.hs +6/−30
- src/Futhark/Representation/Kernels/KernelExp.hs +7/−4
- src/Futhark/Representation/Kernels/Simplify.hs +1/−2
- src/Futhark/Representation/Primitive.hs +2/−0
- src/Futhark/Representation/SOACS.hs +3/−16
- src/Futhark/Representation/SOACS/SOAC.hs +2/−2
- src/Futhark/Representation/SOACS/Simplify.hs +30/−0
- src/Futhark/Test.hs +110/−14
- src/Futhark/Test/Values.hs +38/−28
- src/Futhark/Tools.hs +3/−7
- src/Futhark/TypeCheck.hs +36/−14
- src/Language/Futhark.hs +4/−1
- src/Language/Futhark/Attributes.hs +52/−10
- src/Language/Futhark/Interpreter.hs +63/−23
- src/Language/Futhark/Parser/Lexer.x +13/−6
- src/Language/Futhark/Parser/Parser.y +91/−28
- src/Language/Futhark/Pretty.hs +19/−6
- src/Language/Futhark/Syntax.hs +37/−7
- src/Language/Futhark/Traversals.hs +15/−0
- src/Language/Futhark/TypeChecker.hs +57/−16
- src/Language/Futhark/TypeChecker/Terms.hs +239/−34
- src/Language/Futhark/TypeChecker/Types.hs +46/−12
- src/Language/Futhark/TypeChecker/Unify.hs +62/−8
- src/futhark-bench.hs +25/−19
- src/futhark-dataset.hs +65/−175
- src/futhark.hs +4/−1
- src/futharki.hs +8/−4
futhark.cabal view
@@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 27326a3d0b5daec736d8b0de8fda5938beaf2ee6e75215a5cfb6a29b1008afb0+-- hash: a75ffbf819d567c2108977d336c20ff7f11963b071dc0d9e581faa2f792dba99 name: futhark-version: 0.7.4+version: 0.8.1 synopsis: An optimising compiler for a functional, array-oriented language. description: See the website at https://futhark-lang.org category: Language@@ -49,59 +49,6 @@ location: https://github.com/diku-dk/futhark library- hs-source-dirs:- src- ghc-options: -Wall -Wcompat -Wredundant-constraints -Wincomplete-record-updates -Wmissing-export-lists- build-depends:- ansi-terminal >=0.6.3.1- , array >=0.4- , base >=4 && <5- , bifunctors >=5.4.2- , binary >=0.8.3- , blaze-html >=0.9.0.1- , bytestring >=0.10.8- , containers >=0.5- , data-binary-ieee754 >=0.1- , directory >=1.3.0.0- , directory-tree >=0.12.1- , dlist >=0.6.0.1- , extra >=1.5.3- , file-embed >=0.0.9- , filepath >=1.4.1.1- , free >=4.12.4- , gitrev >=1.2.0- , http-client >=0.5.7.0- , http-client-tls >=0.3.5.1- , http-conduit >=2.2.4- , language-c-quote >=0.12- , mainland-pretty >=0.6.1- , markdown >=0.1.16- , megaparsec >=7.0.1- , mtl >=2.2.1- , neat-interpolation >=0.3- , parallel >=3.2.1.0- , parser-combinators >=1.0.0- , process >=1.4.3.0- , process-extras >=0.7.2- , raw-strings-qq >=1.1- , regex-tdfa >=1.2- , srcloc >=0.4- , template-haskell >=2.11.1- , text >=1.2.2.2- , th-lift-instances >=0.1.11- , time >=1.6.0.1- , transformers >=0.3- , vector >=0.12- , vector-binary-instances >=0.2.2.0- , versions >=3.3.1- , zip-archive >=0.3.1.1- , zlib >=0.6.1.2- build-tools:- alex- , happy- if !impl(ghc >= 8.0)- build-depends:- semigroups ==0.18.* exposed-modules: Futhark.Actions Futhark.Analysis.AlgSimplify@@ -149,6 +96,7 @@ Futhark.CodeGen.ImpGen Futhark.CodeGen.ImpGen.Kernels Futhark.CodeGen.ImpGen.Kernels.ToOpenCL+ Futhark.CodeGen.ImpGen.Kernels.Transpose Futhark.CodeGen.ImpGen.OpenCL Futhark.CodeGen.ImpGen.Sequential Futhark.CodeGen.OpenCL.Kernels@@ -216,6 +164,7 @@ Futhark.Optimise.Simplify.Rule Futhark.Optimise.Simplify.Rules Futhark.Optimise.TileLoops+ Futhark.Optimise.TileLoops.RegTiling3D Futhark.Optimise.Unstream Futhark.Pass Futhark.Pass.ExpandAllocations@@ -305,6 +254,59 @@ Language.Futhark.Parser.Parser Language.Futhark.Parser.Lexer Paths_futhark+ hs-source-dirs:+ src+ ghc-options: -Wall -Wcompat -Wredundant-constraints -Wincomplete-record-updates -Wmissing-export-lists+ build-depends:+ ansi-terminal >=0.6.3.1+ , array >=0.4+ , base >=4 && <5+ , bifunctors >=5.4.2+ , binary >=0.8.3+ , blaze-html >=0.9.0.1+ , bytestring >=0.10.8+ , containers >=0.5+ , data-binary-ieee754 >=0.1+ , directory >=1.3.0.0+ , directory-tree >=0.12.1+ , dlist >=0.6.0.1+ , extra >=1.5.3+ , file-embed >=0.0.9+ , filepath >=1.4.1.1+ , free >=4.12.4+ , gitrev >=1.2.0+ , http-client >=0.5.7.0+ , http-client-tls >=0.3.5.1+ , http-conduit >=2.2.4+ , language-c-quote >=0.12+ , mainland-pretty >=0.6.1+ , markdown >=0.1.16+ , megaparsec >=7.0.1+ , mtl >=2.2.1+ , neat-interpolation >=0.3+ , parallel >=3.2.1.0+ , parser-combinators >=1.0.0+ , process >=1.4.3.0+ , process-extras >=0.7.2+ , raw-strings-qq >=1.1+ , regex-tdfa >=1.2+ , srcloc >=0.4+ , template-haskell >=2.11.1+ , text >=1.2.2.2+ , th-lift-instances >=0.1.11+ , time >=1.6.0.1+ , transformers >=0.3+ , vector >=0.12+ , vector-binary-instances >=0.2.2.0+ , versions >=3.3.1+ , zip-archive >=0.3.1.1+ , zlib >=0.6.1.2+ build-tools:+ alex+ , happy+ if !impl(ghc >= 8.0)+ build-depends:+ semigroups ==0.18.* default-language: Haskell2010 executable futhark@@ -1062,6 +1064,19 @@ test-suite unit type: exitcode-stdio-1.0 main-is: futhark_tests.hs+ other-modules:+ Futhark.Analysis.ScalExpTests+ 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.PrimitiveTests+ Language.Futhark.CoreTests+ Language.Futhark.SyntaxTests+ Paths_futhark hs-source-dirs: unittests ghc-options: -Wall -Wcompat -Wredundant-constraints -Wincomplete-record-updates -Wmissing-export-lists@@ -1118,17 +1133,4 @@ if !impl(ghc >= 8.0) build-depends: semigroups ==0.18.*- other-modules:- Futhark.Analysis.ScalExpTests- 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.PrimitiveTests- Language.Futhark.CoreTests- Language.Futhark.SyntaxTests- Paths_futhark default-language: Haskell2010
rts/c/opencl.h view
@@ -2,6 +2,8 @@ #define CL_USE_DEPRECATED_OPENCL_1_2_APIS +#define CL_SILENCE_DEPRECATION // For macOS.+ #ifdef __APPLE__ #include <OpenCL/cl.h> #else@@ -43,7 +45,6 @@ size_t default_num_groups; size_t default_tile_size; size_t default_threshold;- size_t transpose_block_dim; int default_group_size_changed; int default_tile_size_changed;@@ -73,7 +74,6 @@ cfg->default_num_groups = 128; cfg->default_tile_size = 32; cfg->default_threshold = 32*1024;- cfg->transpose_block_dim = 16; cfg->default_group_size_changed = 0; cfg->default_tile_size_changed = 0;@@ -629,6 +629,10 @@ // Make sure this function is defined. post_opencl_setup(ctx, &device_option); + if (ctx->lockstep_width == 0) {+ ctx->lockstep_width = 1;+ }+ if (ctx->cfg.logging) { fprintf(stderr, "Lockstep width: %d\n", (int)ctx->lockstep_width); fprintf(stderr, "Default group size: %d\n", (int)ctx->cfg.default_group_size);@@ -686,8 +690,7 @@ char *compile_opts = malloc(compile_opts_size); int w = snprintf(compile_opts, compile_opts_size,- "-DFUT_BLOCK_DIM=%d -DLOCKSTEP_WIDTH=%d ",- (int)ctx->cfg.transpose_block_dim,+ "-DLOCKSTEP_WIDTH=%d ", (int)ctx->lockstep_width); for (int i = 0; i < ctx->cfg.num_sizes; i++) {@@ -707,7 +710,7 @@ const char *srcs[], int required_types) { - ctx->lockstep_width = 1;+ ctx->lockstep_width = 0; // Real value set later. free_list_init(&ctx->free_list);
rts/csharp/opencl.cs view
@@ -35,7 +35,6 @@ public int DefaultNumGroups; public int DefaultTileSize; public int DefaultThreshold;- public int TransposeBlockDim; public int NumSizes; public string[] SizeNames;@@ -377,7 +376,6 @@ cfg.DefaultNumGroups = 128; cfg.DefaultTileSize = 32; cfg.DefaultThreshold = 32*1024;- cfg.TransposeBlockDim = 16; cfg.NumSizes = num_sizes; cfg.SizeNames = size_names;@@ -870,8 +868,7 @@ int compile_opts_size = 1024; - string compile_opts = String.Format("-DFUT_BLOCK_DIM={0} -DLOCKSTEP_WIDTH={1} ",- ctx.OpenCL.Cfg.TransposeBlockDim,+ string compile_opts = String.Format("-DLOCKSTEP_WIDTH={0} ", ctx.OpenCL.LockstepWidth); for (int i = 0; i < ctx.OpenCL.Cfg.NumSizes; i++) {
rts/python/opencl.py view
@@ -81,7 +81,6 @@ default_num_groups=None, default_tile_size=None, default_threshold=None,- transpose_block_dim=16, size_heuristics=[], required_types=[], all_sizes={},@@ -167,8 +166,7 @@ if (len(program_src) >= 0): return cl.Program(self.ctx, program_src).build(- ["-DFUT_BLOCK_DIM={}".format(transpose_block_dim),- "-DLOCKSTEP_WIDTH={}".format(lockstep_width)]+ ["-DLOCKSTEP_WIDTH={}".format(lockstep_width)] + ["-D{}={}".format(s,v) for (s,v) in self.sizes.items()]) def opencl_alloc(self, min_size, tag):
rts/python/values.py view
@@ -24,9 +24,12 @@ self.lookahead_buffer = [c] + self.lookahead_buffer def get_chars(self, n):- s = b''- for _ in range(n):- s += self.get_char()+ n1 = min(n, len(self.lookahead_buffer))+ s = b''.join(self.lookahead_buffer[:n1])+ self.lookahead_buffer = self.lookahead_buffer[n1:]+ n2 = n - n1+ if n2 > 0:+ s += self.f.read(n2) return s def peek_char(self):
src/Futhark/Analysis/Metrics.hs view
@@ -123,7 +123,6 @@ primOpMetrics Reshape{} = seen "Reshape" primOpMetrics Rearrange{} = seen "Rearrange" primOpMetrics Rotate{} = seen "Rotate"-primOpMetrics Partition{} = seen "Partition" lambdaMetrics :: OpMetrics (Op lore) => Lambda lore -> MetricsM () lambdaMetrics = bodyMetrics . lambdaBody
src/Futhark/Analysis/PrimExp.hs view
@@ -6,8 +6,11 @@ , evalPrimExp , primExpType , coerceIntPrimExp+ , true+ , false , module Futhark.Representation.Primitive+ , (.&&.), (.||.), (.<.), (.<=.), (.>.), (.>=.), (.==.), (.&.), (.|.), (.^.) ) where import Data.Foldable@@ -150,6 +153,39 @@ fromInt32 = ValueExp . IntValue . Int32Value fromInt64 = ValueExp . IntValue . Int64Value +-- | Lifted logical conjunction.+(.&&.) :: PrimExp v -> PrimExp v -> PrimExp v+x .&&. y = BinOpExp LogAnd x y++-- | Lifted logical conjunction.+(.||.) :: PrimExp v -> PrimExp v -> PrimExp v+x .||. y = BinOpExp LogOr x y++-- | Lifted relational operators; assuming signed numbers in case of+-- integers.+(.<.), (.>.), (.<=.), (.>=.), (.==.) :: PrimExp v -> PrimExp v -> PrimExp v+x .<. y = CmpOpExp cmp x y where cmp = case primExpType x of+ IntType t -> CmpSlt $ t `min` primExpIntType y+ FloatType t -> FCmpLt t+ _ -> CmpLlt+x .<=. y = CmpOpExp cmp x y where cmp = case primExpType x of+ IntType t -> CmpSle $ t `min` primExpIntType y+ FloatType t -> FCmpLe t+ _ -> CmpLle+x .==. y = CmpOpExp (CmpEq $ primExpType x `min` primExpType y) x y+x .>. y = y .<. x+x .>=. y = y .<=. x++-- | Lifted bitwise operators.+(.&.), (.|.), (.^.) :: PrimExp v -> PrimExp v -> PrimExp v+x .&. y = BinOpExp (And $ primExpIntType x `min` primExpIntType y) x y+x .|. y = BinOpExp (Or $ primExpIntType x `min` primExpIntType y) x y+x .^. y = BinOpExp (Xor $ primExpIntType x `min` primExpIntType y) x y++infix 4 .==., .<., .>., .<=., .>=.+infixr 3 .&&.+infixr 2 .||.+ asIntOp :: (IntType -> BinOp) -> PrimExp v -> PrimExp v -> Maybe (PrimExp v) asIntOp f x y | IntType t <- primExpType x,@@ -255,6 +291,15 @@ coerceIntPrimExp :: IntType -> PrimExp v -> PrimExp v coerceIntPrimExp t (ValueExp (IntValue v)) = ValueExp $ IntValue $ doSExt v t coerceIntPrimExp _ e = e++primExpIntType :: PrimExp v -> IntType+primExpIntType e = case primExpType e of IntType t -> t+ _ -> Int64++-- | Boolean-valued PrimExps.+true, false :: PrimExp v+true = ValueExp $ BoolValue True+false = ValueExp $ BoolValue False -- Prettyprinting instances
src/Futhark/Analysis/SymbolTable.hs view
@@ -31,6 +31,8 @@ , lookupValue , lookupVar , lookupAliases+ , available+ , consume , index , index' , IndexOp(..)@@ -131,6 +133,7 @@ , freeVarStmDepth = letBoundStmDepth e , freeVarRange = letBoundRange e , freeVarIndex = \name is -> index' name is table+ , freeVarConsumed = letBoundConsumed e } fParam e = FParam e { fparamAttr = fparamAttr e }@@ -181,6 +184,8 @@ , letBoundScalExp :: Maybe ScalExp , letBoundIndex :: Int -> IndexArray -- ^ Index a delayed array, if possible.+ , letBoundConsumed :: Bool+ -- ^ True if consumed. } data FParamEntry lore =@@ -188,6 +193,7 @@ , fparamAttr :: FParamAttr lore , fparamAliases :: Names , fparamStmDepth :: Int+ , fparamConsumed :: Bool } data LParamEntry lore =@@ -195,6 +201,7 @@ , lparamAttr :: LParamAttr lore , lparamStmDepth :: Int , lparamIndex :: IndexArray+ , lparamConsumed :: Bool } data FreeVarEntry lore =@@ -203,6 +210,8 @@ , freeVarRange :: ScalExpRange , freeVarIndex :: VName -> IndexArray -- ^ Index a delayed array, if possible.+ , freeVarConsumed :: Bool+ -- ^ True if consumed. } entryInfo :: Entry lore -> NameInfo lore@@ -260,6 +269,13 @@ setValueRange range (FreeVar entry) = FreeVar $ entry { freeVarRange = range } +consumed :: Entry lore -> Bool+consumed (LetBound entry) = letBoundConsumed entry+consumed (FParam entry) = fparamConsumed entry+consumed (LParam entry) = lparamConsumed entry+consumed LoopVar{} = False+consumed (FreeVar entry) = freeVarConsumed entry+ entryStm :: Entry lore -> Maybe (Stm lore) entryStm (LetBound entry) = Just $ letBoundStm entry entryStm _ = Nothing@@ -339,6 +355,10 @@ Just (FParam e) -> fparamAliases e _ -> mempty +-- | In symbol table and not consumed.+available :: VName -> SymbolTable lore -> Bool+available name = maybe False (not . consumed) . M.lookup name . bindings+ index :: Attributes lore => VName -> [SubExp] -> SymbolTable lore -> Maybe (PrimExp VName, Certificates) index name is table = do@@ -455,6 +475,7 @@ , letBoundStmDepth = 0 , letBoundIndex = \k -> fmap (second (<>(stmAuxCerts $ stmAux bnd))) . indexExp vtable (stmExp bnd) k+ , letBoundConsumed = False } where ranges :: AS.RangesRep ranges = rangesRep vtable@@ -522,11 +543,12 @@ -> SymbolTable lore -> SymbolTable lore insertStm stm vtable =- foldl' addRevAliases- (insertEntries (zip names $ map LetBound $ bindingEntries stm vtable) vtable) $- patternElements $ stmPattern stm+ flip (foldl' $ flip consume) stm_consumed $+ flip (foldl' addRevAliases) (patternElements $ stmPattern stm) $+ insertEntries (zip names $ map LetBound $ bindingEntries stm vtable) vtable where names = patternNames $ stmPattern stm adjustSeveral f = flip $ foldl' $ flip $ M.adjust f+ stm_consumed = expandAliases (Aliases.consumedInStm stm) vtable addRevAliases vtable' pe = vtable' { bindings = adjustSeveral update inedges $ bindings vtable' } where inedges = expandAliases (Aliases.aliasesOf pe) vtable'@@ -553,6 +575,7 @@ , fparamAttr = AST.paramAttr fparam , fparamAliases = mempty , fparamStmDepth = 0+ , fparamConsumed = False } insertFParams :: Attributes lore =>@@ -573,6 +596,7 @@ , lparamAttr = AST.paramAttr param , lparamStmDepth = 0 , lparamIndex = indexf+ , lparamConsumed = False } name = AST.paramName param sizevars = subExpVars $ arrayDims $ AST.paramType param@@ -626,6 +650,7 @@ , freeVarRange = (Nothing, Nothing) , freeVarStmDepth = 0 , freeVarIndex = \_ _ -> Nothing+ , freeVarConsumed = False } updateBounds :: Attributes lore => Bool -> SubExp -> SymbolTable lore -> SymbolTable lore@@ -725,6 +750,16 @@ (S.insert sym cur_syms) (S.toList $ S.fromList sym_bds) Nothing -> S.insert sym cur_syms++consume :: Attributes lore => VName -> SymbolTable lore -> SymbolTable lore+consume consumee vtable = foldl' consume' vtable $ expandAliases (S.singleton consumee) vtable+ where consume' vtable' v | Just e <- lookup v vtable = insertEntry v (consume'' e) vtable'+ | otherwise = vtable'+ consume'' (FreeVar e) = FreeVar e { freeVarConsumed = True }+ consume'' (LetBound e) = LetBound e { letBoundConsumed = True }+ consume'' (FParam e) = FParam e { fparamConsumed = True }+ consume'' (LParam e) = LParam e { lparamConsumed = True }+ consume'' (LoopVar e) = LoopVar e setUpperBound :: VName -> ScalExp -> SymbolTable lore -> SymbolTable lore
src/Futhark/CodeGen/Backends/COpenCL.hs view
@@ -124,12 +124,22 @@ } ] +-- We detect the special case of writing a constant and turn it into a+-- non-blocking write. This may be slightly faster, as it prevents+-- unnecessary synchronisation of the OpenCL command queue, and+-- writing a constant is fairly common. This is only possible because+-- we can give the constant infinite lifetime (with 'static'), which+-- is not the case for ordinary variables. writeOpenCLScalar :: GC.WriteScalar OpenCL () writeOpenCLScalar mem i t "device" _ val = do val' <- newVName "write_tmp"- GC.stm [C.cstm|{$ty:t $id:val' = $exp:val;+ let (decl, blocking) =+ case val of+ C.Const{} -> ([C.citem|static $ty:t $id:val' = $exp:val;|], [C.cexp|CL_FALSE|])+ _ -> ([C.citem|$ty:t $id:val' = $exp:val;|], [C.cexp|CL_TRUE|])+ GC.stm [C.cstm|{$item:decl OPENCL_SUCCEED_OR_RETURN(- clEnqueueWriteBuffer(ctx->opencl.queue, $exp:mem, CL_TRUE,+ clEnqueueWriteBuffer(ctx->opencl.queue, $exp:mem, $exp:blocking, $exp:i, sizeof($ty:t), &$id:val', 0, NULL, NULL));
src/Futhark/CodeGen/Backends/COpenCL/Boilerplate.hs view
@@ -70,7 +70,6 @@ };|]) let size_value_inits = map (\i -> [C.cstm|cfg->sizes[$int:i] = 0;|]) [0..M.size sizes-1]- transposeBlockDim' = transposeBlockDim :: Int GC.publicDef_ "context_config_new" GC.InitDecl $ \s -> ([C.cedecl|struct $id:cfg* $id:s(void);|], [C.cedecl|struct $id:cfg* $id:s(void) {@@ -82,8 +81,6 @@ $stms:size_value_inits opencl_config_init(&cfg->opencl, $int:num_sizes, size_names, cfg->sizes, size_classes, size_entry_points);-- cfg->opencl.transpose_block_dim = $int:transposeBlockDim'; return cfg; }|])
src/Futhark/CodeGen/Backends/CSOpenCL/Boilerplate.hs view
@@ -79,7 +79,6 @@ , Reassign (Field tmp_cfg "Sizes") (Collection "int[]" (replicate (M.size sizes) (Integer 0))) , Exp $ CS.simpleCall "OpenCLConfigInit" [ Out $ Field tmp_cfg "OpenCL", (Integer . toInteger) $ M.size sizes , Var "SizeNames", Field tmp_cfg "Sizes", Var "SizeClasses" ]- , Reassign (Field tmp_cfg "OpenCL.TransposeBlockDim") (Integer transposeBlockDim) , Return tmp_cfg ]
src/Futhark/CodeGen/Backends/GenericC.hs view
@@ -741,7 +741,7 @@ ctx_ty <- contextType headerDecl (ArrayDecl name)- [C.cedecl|struct $id:name;|]+ [C.cedecl|struct $id:arr_name;|] headerDecl (ArrayDecl name) [C.cedecl|$ty:array_type* $id:new_array($ty:ctx_ty *ctx, $ty:pt' *data, $params:shape_params);|] headerDecl (ArrayDecl name)
src/Futhark/CodeGen/ImpCode.hs view
@@ -327,7 +327,7 @@ ppr (SetMem dest from space) = ppr dest <+> text "<-" <+> ppr from <+> text "@" <> ppr space ppr (Assert e msg _) =- text "assert" <> parens (commasep [text (show msg), ppr e])+ text "assert" <> parens (commasep [ppr msg, ppr e]) ppr (Copy dest destoffset destspace src srcoffset srcspace size) = text "memcpy" <> parens (ppMemLoc dest destoffset <> ppr destspace <> comma </>
src/Futhark/CodeGen/ImpCode/Kernels.hs view
@@ -21,6 +21,7 @@ , module Futhark.Representation.Kernels.Sizes -- * Utility functions , getKernels+ , atomicBinOp ) where @@ -57,7 +58,6 @@ data CallKernel = Map MapKernel | AnyKernel Kernel- | MapTranspose PrimType VName Exp VName Exp Exp Exp Exp Exp Exp deriving (Show) -- | A generic kernel containing arbitrary kernel code.@@ -83,12 +83,10 @@ , kernelUses :: [KernelUse] -- ^ The host variables referenced by the kernel. - , kernelNumGroups :: DimSize- , kernelGroupSize :: DimSize- , kernelName :: VName- -- ^ Unique name for the kernel.- , kernelDesc :: String- -- ^ A short descriptive name - should be+ , kernelNumGroups :: [Imp.Exp]+ , kernelGroupSize :: [Imp.Exp]+ , kernelName :: Name+ -- ^ A short descriptive and _unique_ name - should be -- alphanumeric and without spaces. } deriving (Show)@@ -97,7 +95,7 @@ type LocalMemoryUse = (VName, Either MemSize KernelConstExp) data KernelUse = ScalarUse VName PrimType- | MemoryUse VName Imp.DimSize+ | MemoryUse VName | ConstUse VName KernelConstExp deriving (Eq, Show) @@ -107,18 +105,28 @@ tell [kernel] getFunKernels _ = return ()- sameKernel (MapTranspose bt1 _ _ _ _ _ _ _ _ _) (MapTranspose bt2 _ _ _ _ _ _ _ _ _) =- bt1 == bt2 sameKernel _ _ = False +-- | Get an atomic operator corresponding to a binary operator.+atomicBinOp :: BinOp -> Maybe (VName -> VName -> Count Bytes -> Exp -> AtomicOp)+atomicBinOp = flip lookup [ (Add Int32, AtomicAdd)+ , (SMax Int32, AtomicSMax)+ , (SMin Int32, AtomicSMin)+ , (UMax Int32, AtomicUMax)+ , (UMin Int32, AtomicUMin)+ , (And Int32, AtomicAnd)+ , (Or Int32, AtomicOr)+ , (Xor Int32, AtomicXor)+ ]+ instance Pretty KernelConst where ppr (SizeConst key) = text "get_size" <> parens (ppr key) instance Pretty KernelUse where ppr (ScalarUse name t) = text "scalar_copy" <> parens (commasep [ppr name, ppr t])- ppr (MemoryUse name size) =- text "mem_copy" <> parens (commasep [ppr name, ppr size])+ ppr (MemoryUse name) =+ text "mem_copy" <> parens (commasep [ppr name]) ppr (ConstUse name e) = text "const" <> parens (commasep [ppr name, ppr e]) @@ -147,25 +155,10 @@ instance Pretty CallKernel where ppr (Map k) = ppr k ppr (AnyKernel k) = ppr k- ppr (MapTranspose bt dest destoffset src srcoffset num_arrays size_x size_y in_size out_size) =- text "mapTranspose" <>- parens (ppr bt <> comma </>- ppMemLoc dest destoffset <> comma </>- ppMemLoc src srcoffset <> comma </>- ppr num_arrays <> comma <+>- ppr size_x <> comma <+>- ppr size_y <> comma <+>- ppr in_size <> comma <+>- ppr out_size)- where ppMemLoc base offset =- ppr base <+> text "+" <+> ppr offset instance FreeIn CallKernel where freeIn (Map k) = freeIn k freeIn (AnyKernel k) = freeIn k- freeIn (MapTranspose _ dest destoffset src srcoffset num_arrays size_x size_y in_size out_size) =- freeIn [dest, src] <> freeIn [destoffset, srcoffset] <> freeIn num_arrays <>- freeIn [size_x, size_y] <> freeIn [in_size, out_size] instance FreeIn Kernel where freeIn kernel = freeIn (kernelBody kernel) <>
src/Futhark/CodeGen/ImpCode/OpenCL.hs view
@@ -14,7 +14,6 @@ , KernelName , KernelArg (..) , OpenCL (..)- , transposeBlockDim , module Futhark.CodeGen.ImpCode , module Futhark.Representation.Kernels.Sizes )@@ -65,10 +64,6 @@ | CmpSizeLe VName VName Exp | GetSizeMax VName SizeClass deriving (Show)---- | The block size when transposing.-transposeBlockDim :: Num a => a-transposeBlockDim = 16 instance Pretty OpenCL where ppr = text . show
src/Futhark/CodeGen/ImpGen.hs view
@@ -9,21 +9,26 @@ , OpCompiler , ExpCompiler , CopyCompiler- , BodyCompiler+ , StmsCompiler , Operations (..) , defaultOperations- , Destination (..)- , ValueDestination (..)+ , ValueDestination+ , arrayDestination , MemLocation (..) , MemEntry (..) , ScalarEntry (..) -- * Monadic Compiler Interface , ImpM- , Env (envVtable, envDefaultSpace)+ , Env (envDefaultSpace)+ , VTable+ , getVTable+ , localVTable , subImpM , subImpM_ , emit+ , emitFunction+ , hasFunction , collect , comment , VarEntry (..)@@ -32,7 +37,6 @@ -- * Lookups , lookupVar , lookupArray- , arrayLocation , lookupMemory -- * Building Blocks@@ -42,22 +46,14 @@ , compilePrimExp , compileAlloc , subExpToDimSize- , declaringLParams- , declaringFParams- , declaringVarEntry- , declaringScope- , declaringScopes- , declaringPrimVar- , declaringPrimVars- , withPrimVar , everythingVolatile , compileBody+ , compileBody' , compileLoopBody- , defCompileBody+ , defCompileStms , compileStms , compileExp , defCompileExp- , sliceArray , offsetArray , strideArray , fullyIndexArray@@ -65,19 +61,32 @@ , varIndex , Imp.dimSizeToExp , dimSizeToSubExp- , destinationFromParam- , destinationFromParams- , destinationFromPattern- , funcallTargets , copy , copyDWIM , copyDWIMDest , copyElementWise++ -- * Constructing code.+ , dLParams+ , dFParams+ , dScope+ , dScopes+ , dArray+ , dPrim, dPrim_, dPrimV++ , sFor, sWhile+ , sComment+ , sIf, sWhen, sUnless+ , sOp+ , sAlloc+ , sArray+ , sWrite+ , (<--) ) where import Control.Monad.RWS hiding (mapM, forM)-import Control.Monad.State hiding (mapM, forM)+import Control.Monad.State hiding (mapM, forM, State) import Control.Monad.Writer hiding (mapM, forM) import Control.Monad.Except hiding (mapM, forM) import qualified Control.Monad.Fail as Fail@@ -102,13 +111,13 @@ import Futhark.Util -- | How to compile an 'Op'.-type OpCompiler lore op = Destination -> Op lore -> ImpM lore op ()+type OpCompiler lore op = Pattern lore -> Op lore -> ImpM lore op () --- | How to compile a 'Body'.-type BodyCompiler lore op = Destination -> Body lore -> ImpM lore op ()+-- | How to compile some 'Stms'.+type StmsCompiler lore op = Names -> [Stm lore] -> ImpM lore op () -> ImpM lore op () -- | How to compile an 'Exp'.-type ExpCompiler lore op = Destination -> Exp lore -> ImpM lore op ()+type ExpCompiler lore op = Pattern lore -> Exp lore -> ImpM lore op () type CopyCompiler lore op = PrimType -> MemLocation@@ -118,7 +127,7 @@ data Operations lore op = Operations { opsExpCompiler :: ExpCompiler lore op , opsOpCompiler :: OpCompiler lore op- , opsBodyCompiler :: BodyCompiler lore op+ , opsStmsCompiler :: StmsCompiler lore op , opsCopyCompiler :: CopyCompiler lore op } @@ -128,11 +137,11 @@ OpCompiler lore op -> Operations lore op defaultOperations opc = Operations { opsExpCompiler = defCompileExp , opsOpCompiler = opc- , opsBodyCompiler = defCompileBody+ , opsStmsCompiler = defCompileStms , opsCopyCompiler = defaultCopy } --- | When an array is declared, this is where it is stored.+-- | When an array is dared, this is where it is stored. data MemLocation = MemLocation { memLocationName :: VName , memLocationShape :: [Imp.DimSize] , memLocationIxFun :: IxFun.IxFun Imp.Exp@@ -171,7 +180,6 @@ deriving (Show) data ValueDestination = ScalarDestination VName- | ArrayElemDestination VName PrimType Imp.Space (Count Bytes) | MemoryDestination VName | ArrayDestination (Maybe MemLocation) -- ^ The 'MemLocation' is 'Just' if a copy if@@ -180,16 +188,12 @@ -- takes care of this array. deriving (Show) --- | If the given value destination if a 'ScalarDestination', return--- the variable name. Otherwise, 'Nothing'.-fromScalarDestination :: ValueDestination -> Maybe VName-fromScalarDestination (ScalarDestination name) = Just name-fromScalarDestination _ = Nothing+arrayDestination :: MemLocation -> ValueDestination+arrayDestination = ArrayDestination . Just data Env lore op = Env {- envVtable :: M.Map VName (VarEntry lore)- , envExpCompiler :: ExpCompiler lore op- , envBodyCompiler :: BodyCompiler lore op+ envExpCompiler :: ExpCompiler lore op+ , envStmsCompiler :: StmsCompiler lore op , envOpCompiler :: OpCompiler lore op , envCopyCompiler :: CopyCompiler lore op , envDefaultSpace :: Imp.Space@@ -197,18 +201,28 @@ } newEnv :: Operations lore op -> Imp.Space -> Env lore op-newEnv ops ds = Env { envVtable = M.empty- , envExpCompiler = opsExpCompiler ops- , envBodyCompiler = opsBodyCompiler ops+newEnv ops ds = Env { envExpCompiler = opsExpCompiler ops+ , envStmsCompiler = opsStmsCompiler ops , envOpCompiler = opsOpCompiler ops , envCopyCompiler = opsCopyCompiler ops , envDefaultSpace = ds , envVolatility = Imp.Nonvolatile } -newtype ImpM lore op a = ImpM (RWST (Env lore op) (Imp.Code op) VNameSource (Either InternalError) a)+-- | The symbol table used during compilation.+type VTable lore = M.Map VName (VarEntry lore)++data State lore op = State { stateVTable :: VTable lore+ , stateFunctions :: Imp.Functions op+ , stateNameSource :: VNameSource+ }++newState :: VNameSource -> State lore op+newState = State mempty mempty++newtype ImpM lore op a = ImpM (RWST (Env lore op) (Imp.Code op) (State lore op) (Either InternalError) a) deriving (Functor, Applicative, Monad,- MonadState VNameSource,+ MonadState (State lore op), MonadReader (Env lore op), MonadWriter (Imp.Code op), MonadError InternalError)@@ -217,12 +231,11 @@ fail = error . ("ImpM.fail: "++) instance MonadFreshNames (ImpM lore op) where- getNameSource = get- putNameSource = put-+ getNameSource = gets stateNameSource+ putNameSource src = modify $ \s -> s { stateNameSource = src } instance HasScope SOACS (ImpM lore op) where- askScope = M.map (LetInfo . entryType) <$> asks envVtable+ askScope = M.map (LetInfo . entryType) <$> gets stateVTable where entryType (MemVar _ memEntry) = Mem (dimSizeToSubExp $ entryMemSize memEntry) (entryMemSpace memEntry) entryType (ArrayVar _ arrayEntry) =@@ -235,8 +248,10 @@ runImpM :: ImpM lore op a -> Operations lore op -> Imp.Space -> VNameSource- -> Either InternalError (a, VNameSource, Imp.Code op)-runImpM (ImpM m) comp = runRWST m . newEnv comp+ -> Either InternalError (a, VNameSource, Imp.Code op, Imp.Functions op)+runImpM (ImpM m) comp space src = do+ (a, s, code) <- runRWST m (newEnv comp space) (newState src)+ return (a, stateNameSource s, code, stateFunctions s) subImpM_ :: Operations lore' op' -> ImpM lore' op' a -> ImpM lore op (Imp.Code op')@@ -246,17 +261,17 @@ -> ImpM lore op (a, Imp.Code op') subImpM ops (ImpM m) = do env <- ask- src <- getNameSource+ s <- get case runRWST m env { envExpCompiler = opsExpCompiler ops- , envBodyCompiler = opsBodyCompiler ops+ , envStmsCompiler = opsStmsCompiler ops , envCopyCompiler = opsCopyCompiler ops , envOpCompiler = opsOpCompiler ops- , envVtable = M.map scrubExps $ envVtable env }- src of+ s { stateVTable = M.map scrubExps $ stateVTable s+ , stateFunctions = mempty } of Left err -> throwError err- Right (x, src', code) -> do- putNameSource src'+ Right (x, s', code) -> do+ putNameSource $ stateNameSource s' return (x, code) where scrubExps (ArrayVar _ entry) = ArrayVar Nothing entry scrubExps (MemVar _ entry) = MemVar Nothing entry@@ -284,14 +299,25 @@ emit :: Imp.Code op -> ImpM lore op () emit = tell +-- | Emit a function in the generated code.+emitFunction :: Name -> Imp.Function op -> ImpM lore op ()+emitFunction fname fun = do+ Imp.Functions fs <- gets stateFunctions+ modify $ \s -> s { stateFunctions = Imp.Functions $ (fname,fun) : fs }++-- | Check if a function of a given name exists.+hasFunction :: Name -> ImpM lore op Bool+hasFunction fname = gets $ \s -> let Imp.Functions fs = stateFunctions s+ in isJust $ lookup fname fs+ compileProg :: (ExplicitMemorish lore, MonadFreshNames m) => Operations lore op -> Imp.Space -> Prog lore -> m (Either InternalError (Imp.Functions op))-compileProg ops ds prog =+compileProg ops space prog = modifyNameSource $ \src ->- case mapAccumLM (compileFunDef ops ds) src (progFunctions prog) of+ case runImpM (mapM_ compileFunDef $ progFunctions prog) ops space src of Left err -> (Left err, src)- Right (src', funs) -> (Right $ Imp.Functions funs, src')+ Right ((), src', _, fs) -> (Right fs, src') compileInParam :: ExplicitMemorish lore => FParam lore -> ImpM lore op (Either Imp.Param ArrayDecl)@@ -319,8 +345,8 @@ compileInParams params orig_epts = do let (ctx_params, val_params) = splitAt (length params - sum (map entryPointSize orig_epts)) params- (inparams, arraydecls) <- partitionEithers <$> mapM compileInParam (ctx_params++val_params)- let findArray x = find (isArrayDecl x) arraydecls+ (inparams, arrayds) <- partitionEithers <$> mapM compileInParam (ctx_params++val_params)+ let findArray x = find (isArrayDecl x) arrayds sizes = mconcat $ map fparamSizes $ ctx_params++val_params summaries = M.fromList $ mapMaybe memSummary params@@ -361,7 +387,7 @@ mkExts epts fparams mkExts _ _ = [] - return (inparams, arraydecls, mkExts orig_epts val_params)+ return (inparams, arrayds, mkExts orig_epts val_params) where isArrayDecl x (ArrayDecl y _ _) = x == y compileOutParams :: ExplicitMemorish lore =>@@ -442,37 +468,36 @@ ensureMemSizeOut (Free v) = imp $ subExpToDimSize v compileFunDef :: ExplicitMemorish lore =>- Operations lore op -> Imp.Space- -> VNameSource- -> FunDef lore- -> Either InternalError (VNameSource, (Name, Imp.Function op))-compileFunDef ops ds src (FunDef entry fname rettype params body) = do- ((outparams, inparams, results, args), src', body') <-- runImpM compile ops ds src- return (src',- (fname,- Imp.Function (isJust entry) outparams inparams body' results args))+ FunDef lore+ -> ImpM lore op ()+compileFunDef (FunDef entry fname rettype params body) = do+ ((outparams, inparams, results, args), body') <- collect' compile+ emitFunction fname $ Imp.Function (isJust entry) outparams inparams body' results args where params_entry = maybe (replicate (length params) TypeDirect) fst entry ret_entry = maybe (replicate (length rettype) TypeDirect) snd entry compile = do- (inparams, arraydecls, args) <- compileInParams params params_entry- (results, outparams, dests) <- compileOutParams rettype ret_entry- withFParams params $- withArrays arraydecls $- compileBody dests body+ (inparams, arrayds, args) <- compileInParams params params_entry+ (results, outparams, Destination _ dests) <- compileOutParams rettype ret_entry+ addFParams params+ addArrays arrayds++ let Body _ stms ses = body+ compileStms (freeIn ses) (stmsToList stms) $+ forM_ (zip dests ses) $ \(d, se) -> copyDWIMDest d [] se []+ return (outparams, inparams, results, args) -compileBody :: Destination -> Body lore -> ImpM lore op ()-compileBody dest body = do- cb <- asks envBodyCompiler- cb dest body+compileBody :: (ExplicitMemorish lore) => Pattern lore -> Body lore -> ImpM lore op ()+compileBody pat (Body _ bnds ses) = do+ Destination _ dests <- destinationFromPattern pat+ compileStms (freeIn ses) (stmsToList bnds) $+ forM_ (zip dests ses) $ \(d, se) -> copyDWIMDest d [] se [] -defCompileBody :: (ExplicitMemorish lore, FreeIn op) => Destination -> Body lore -> ImpM lore op ()-defCompileBody (Destination _ dest) (Body _ bnds ses) =- compileStms (freeIn ses) (stmsToList bnds) $ zipWithM_ compileSubExpTo dest ses+compileBody' :: (ExplicitMemorish lore, attr ~ LetAttr lore)+ => [Param attr] -> Body lore -> ImpM lore op ()+compileBody' = compileBody . patternFromParams -compileLoopBody :: (ExplicitMemorish lore, FreeIn op) =>- [VName] -> Body lore -> ImpM lore op (Imp.Code op)+compileLoopBody :: [VName] -> Body lore -> ImpM lore op () compileLoopBody mergenames (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@@ -481,7 +506,7 @@ -- buffer to the merge parameters. This is efficient, because the -- operations are all scalar operations. tmpnames <- mapM (newVName . (++"_tmp") . baseString) mergenames- collect $ compileStms (freeIn ses) (stmsToList bnds) $ do+ compileStms (freeIn ses) (stmsToList bnds) $ do copy_to_merge_params <- forM (zip3 mergenames tmpnames ses) $ \(d,tmp,se) -> subExpType se >>= \case Prim bt -> do@@ -496,19 +521,23 @@ _ -> return $ return () sequence_ copy_to_merge_params -compileStms :: (ExplicitMemorish lore, FreeIn op) =>- Names -> [Stm lore] -> ImpM lore op () -> ImpM lore op ()-compileStms alive_after_stms all_stms m =+compileStms :: Names -> [Stm lore] -> ImpM lore op () -> ImpM lore op ()+compileStms alive_after_stms all_stms m = do+ cb <- asks envStmsCompiler+ cb alive_after_stms all_stms m++defCompileStms :: (ExplicitMemorish lore, FreeIn op) =>+ Names -> [Stm lore] -> ImpM lore op () -> ImpM lore op ()+defCompileStms alive_after_stms all_stms m = -- We keep track of any memory blocks produced by the statements, -- and after the last time that memory block is used, we insert a -- Free. This is very conservative, but can cut down on lifetimes -- in some cases. void $ compileStms' mempty all_stms- where compileStms' allocs (Let pat _ e:bs) =- declaringVars (Just e) (patternElements pat) $ do- dest <- destinationFromPattern pat+ where compileStms' allocs (Let pat _ e:bs) = do+ dVars (Just e) (patternElements pat) - e_code <- collect $ compileExp dest e+ e_code <- collect $ compileExp pat e (live_after, bs_code) <- collect' $ compileStms' (patternAllocs pat <> allocs) bs let dies_here v = not (v `S.member` live_after) && v `S.member` freeIn e_code@@ -529,21 +558,22 @@ Mem _ space -> Just (patElemName pe, space) _ -> Nothing -compileExp :: Destination -> Exp lore -> ImpM lore op ()-compileExp targets e = do+compileExp :: Pattern lore -> Exp lore -> ImpM lore op ()+compileExp pat e = do ec <- asks envExpCompiler- ec targets e+ ec pat e -defCompileExp :: (ExplicitMemorish lore, FreeIn op) =>- Destination -> Exp lore -> ImpM lore op ()+defCompileExp :: (ExplicitMemorish lore) =>+ Pattern lore -> Exp lore -> ImpM lore op () -defCompileExp dest (If cond tbranch fbranch _) = do+defCompileExp pat (If cond tbranch fbranch _) = do cond' <- compileSubExp cond- tcode <- collect $ compileBody dest tbranch- fcode <- collect $ compileBody dest fbranch+ tcode <- collect $ compileBody pat tbranch+ fcode <- collect $ compileBody pat fbranch emit $ Imp.If cond' tcode fcode -defCompileExp dest (Apply fname args _ _) = do+defCompileExp pat (Apply fname args _ _) = do+ dest <- destinationFromPattern pat targets <- funcallTargets dest args' <- catMaybes <$> mapM compileArg args emit $ Imp.Call targets fname args'@@ -554,158 +584,141 @@ (Var v, Mem{}) -> return $ Just $ Imp.MemArg v _ -> return Nothing -defCompileExp targets (BasicOp op) = defCompileBasicOp targets op+defCompileExp pat (BasicOp op) = defCompileBasicOp pat op -defCompileExp (Destination _ dest) (DoLoop ctx val form body) =- declaringFParams mergepat $ do- forM_ merge $ \(p, se) -> do- na <- subExpNotArray se- when na $- copyDWIM (paramName p) [] se []- (bindForm, emitForm) <-- case form of- ForLoop i it bound loopvars -> do- bound' <- compileSubExp bound- let setLoopParam (p,a)- | Prim _ <- paramType p =- copyDWIM (paramName p) [] (Var a) [varIndex i]- | otherwise =- return ()+defCompileExp pat (DoLoop ctx val form body) = do+ dFParams mergepat+ forM_ merge $ \(p, se) -> do+ na <- subExpNotArray se+ when na $+ copyDWIM (paramName p) [] se [] - let emitForm body' = do- set_loop_params <- collect $ mapM_ setLoopParam loopvars- emit $ Imp.For i it bound' $ set_loop_params<>body'- return (declaringLParams (map fst loopvars) .- declaringLoopVar i it,- emitForm)- WhileLoop cond ->- return (id, emit . Imp.While (Imp.var cond Bool))+ let doBody = compileLoopBody mergenames body - bindForm $ do- body' <- compileLoopBody mergenames body- emitForm body'- zipWithM_ compileSubExpTo dest $ map (Var . paramName . fst) merge- where merge = ctx ++ val- mergepat = map fst merge- mergenames = map paramName mergepat+ case form of+ ForLoop i it bound loopvars -> do+ bound' <- compileSubExp bound -defCompileExp dest (Op op) = do+ let setLoopParam (p,a)+ | Prim _ <- paramType p =+ copyDWIM (paramName p) [] (Var a) [varIndex i]+ | otherwise =+ return ()++ dLParams $ map fst loopvars+ sFor i it bound' $ mapM_ setLoopParam loopvars >> doBody+ WhileLoop cond ->+ sWhile (Imp.var cond Bool) doBody++ Destination _ pat_dests <- destinationFromPattern pat+ forM_ (zip pat_dests $ map (Var . paramName . fst) merge) $ \(d, r) ->+ copyDWIMDest d [] r []++ where merge = ctx ++ val+ mergepat = map fst merge+ mergenames = map paramName mergepat++defCompileExp pat (Op op) = do opc <- asks envOpCompiler- opc dest op+ opc pat op -defCompileBasicOp :: Destination -> BasicOp lore -> ImpM lore op ()+defCompileBasicOp :: ExplicitMemorish lore =>+ Pattern lore -> BasicOp lore -> ImpM lore op () -defCompileBasicOp (Destination _ [target]) (SubExp se) =- compileSubExpTo target se+defCompileBasicOp (Pattern _ [pe]) (SubExp se) =+ copyDWIM (patElemName pe) [] se [] -defCompileBasicOp (Destination _ [target]) (Opaque se) =- compileSubExpTo target se+defCompileBasicOp (Pattern _ [pe]) (Opaque se) =+ copyDWIM (patElemName pe) [] se [] -defCompileBasicOp (Destination _ [target]) (UnOp op e) = do+defCompileBasicOp (Pattern _ [pe]) (UnOp op e) = do e' <- compileSubExp e- writeExp target $ Imp.UnOpExp op e'+ patElemName pe <-- Imp.UnOpExp op e' -defCompileBasicOp (Destination _ [target]) (ConvOp conv e) = do+defCompileBasicOp (Pattern _ [pe]) (ConvOp conv e) = do e' <- compileSubExp e- writeExp target $ Imp.ConvOpExp conv e'+ patElemName pe <-- Imp.ConvOpExp conv e' -defCompileBasicOp (Destination _ [target]) (BinOp bop x y) = do+defCompileBasicOp (Pattern _ [pe]) (BinOp bop x y) = do x' <- compileSubExp x y' <- compileSubExp y- writeExp target $ Imp.BinOpExp bop x' y'+ patElemName pe <-- Imp.BinOpExp bop x' y' -defCompileBasicOp (Destination _ [target]) (CmpOp bop x y) = do+defCompileBasicOp (Pattern _ [pe]) (CmpOp bop x y) = do x' <- compileSubExp x y' <- compileSubExp y- writeExp target $ Imp.CmpOpExp bop x' y'+ patElemName pe <-- Imp.CmpOpExp bop x' y' -defCompileBasicOp (Destination _ [_]) (Assert e msg loc) = do+defCompileBasicOp _ (Assert e msg loc) = do e' <- compileSubExp e msg' <- traverse compileSubExp msg emit $ Imp.Assert e' msg' loc -defCompileBasicOp (Destination _ [target]) (Index src slice)+defCompileBasicOp (Pattern _ [pe]) (Index src slice) | Just idxs <- sliceIndices slice =- copyDWIMDest target [] (Var src) $ map (compileSubExpOfType int32) idxs+ copyDWIM (patElemName pe) [] (Var src) $ map (compileSubExpOfType int32) idxs defCompileBasicOp _ Index{} = return () -defCompileBasicOp (Destination _ [ArrayDestination (Just memloc)]) (Update _ slice se)- | MemLocation mem shape ixfun <- memloc = do- bt <- elemType <$> subExpType se- target' <-- case sliceIndices slice of- Just is -> do- (_, space, elemOffset) <-- fullyIndexArray'- (MemLocation mem shape ixfun)- (map (compileSubExpOfType int32) is)- bt- return $ ArrayElemDestination mem bt space elemOffset- Nothing ->- let memdest = sliceArray (MemLocation mem shape ixfun) $- map (fmap (compileSubExpOfType int32)) slice- in return $ ArrayDestination $ Just memdest-- copyDWIMDest target' [] se []+defCompileBasicOp (Pattern _ [pe]) (Update _ slice se) = do+ MemLocation mem shape ixfun <- entryArrayLocation <$> lookupArray (patElemName pe)+ let memdest = sliceArray (MemLocation mem shape ixfun) $+ map (fmap (compileSubExpOfType int32)) slice+ copyDWIMDest (ArrayDestination $ Just memdest) [] se [] -defCompileBasicOp (Destination _ [dest]) (Replicate (Shape ds) se) = do- is <- replicateM (length ds) (newVName "i")+defCompileBasicOp (Pattern _ [pe]) (Replicate (Shape ds) se) = do ds' <- mapM compileSubExp ds- declaringLoopVars Int32 is $ do- copy_elem <- collect $ copyDWIMDest dest (map varIndex is) se []- emit $ foldl (.) id (zipWith (`Imp.For` Int32) is ds') copy_elem+ is <- replicateM (length ds) (newVName "i")+ copy_elem <- collect $ copyDWIM (patElemName pe) (map varIndex is) se []+ emit $ foldl (.) id (zipWith (`Imp.For` Int32) is ds') copy_elem -defCompileBasicOp (Destination _ [_]) Scratch{} =+defCompileBasicOp _ Scratch{} = return () -defCompileBasicOp (Destination _ [dest]) (Iota n e s et) = do+defCompileBasicOp (Pattern [] [pe]) (Iota n e s et) = do i <- newVName "i" x <- newVName "x" n' <- compileSubExp n e' <- compileSubExp e s' <- compileSubExp s- emit $ Imp.DeclareScalar x $ IntType et let i' = ConvOpExp (SExt Int32 et) $ Imp.var i $ IntType Int32- declaringLoopVar i Int32 $ withPrimVar x (IntType et) $- emit =<< (Imp.For i Int32 n' <$>- collect (do emit $ Imp.SetScalar x $ e' + i' * s'- copyDWIMDest dest [varIndex i] (Var x) []))+ dPrim_ x $ IntType et+ sFor i Int32 n' $ do+ x <-- e' + i' * s'+ copyDWIM (patElemName pe) [varIndex i] (Var x) [] -defCompileBasicOp (Destination _ [target]) (Copy src) =- compileSubExpTo target $ Var src+defCompileBasicOp (Pattern _ [pe]) (Copy src) =+ copyDWIM (patElemName pe) [] (Var src) [] -defCompileBasicOp (Destination _ [target]) (Manifest _ src) =- compileSubExpTo target $ Var src+defCompileBasicOp (Pattern _ [pe]) (Manifest _ src) =+ copyDWIM (patElemName pe) [] (Var src) [] -defCompileBasicOp- (Destination _ [ArrayDestination (Just (MemLocation destmem destshape destixfun))])- (Concat i x ys _) = do+defCompileBasicOp (Pattern _ [pe]) (Concat i x ys _) = do+ MemLocation destmem destshape destixfun <-+ entryArrayLocation <$> lookupArray (patElemName pe) xtype <- lookupType x- offs_glb <- newVName "tmp_offs"- withPrimVar offs_glb int32 $ do- emit $ Imp.DeclareScalar offs_glb int32- emit $ Imp.SetScalar offs_glb 0- let perm = [i] ++ [0..i-1] ++ [i+1..length destshape-1]- invperm = rearrangeInverse perm- destloc = MemLocation destmem destshape- (IxFun.permute (IxFun.offsetIndex (IxFun.permute destixfun perm) $- varIndex offs_glb)- invperm)+ offs_glb <- dPrim "tmp_offs" int32+ emit $ Imp.SetScalar offs_glb 0+ let perm = [i] ++ [0..i-1] ++ [i+1..length destshape-1]+ invperm = rearrangeInverse perm+ destloc = MemLocation destmem destshape+ (IxFun.permute (IxFun.offsetIndex (IxFun.permute destixfun perm) $+ varIndex offs_glb)+ invperm) - forM_ (x:ys) $ \y -> do- yentry <- lookupArray y- let srcloc = entryArrayLocation yentry- rows = case drop i $ entryArrayShape yentry of- [] -> error $ "defCompileBasicOp Concat: empty array shape for " ++ pretty y- r:_ -> innerExp $ Imp.dimSizeToExp r- copy (elemType xtype) destloc srcloc $ arrayOuterSize yentry- emit $ Imp.SetScalar offs_glb $ Imp.var offs_glb int32 + rows+ forM_ (x:ys) $ \y -> do+ yentry <- lookupArray y+ let srcloc = entryArrayLocation yentry+ rows = case drop i $ entryArrayShape yentry of+ [] -> error $ "defCompileBasicOp Concat: empty array shape for " ++ pretty y+ r:_ -> innerExp $ Imp.dimSizeToExp r+ copy (elemType xtype) destloc srcloc $ arrayOuterSize yentry+ emit $ Imp.SetScalar offs_glb $ Imp.var offs_glb int32 + rows -defCompileBasicOp (Destination _ [dest]) (ArrayLit es _)- | ArrayDestination (Just dest_mem) <- dest,- Just vs@(v:_) <- mapM isLiteral es = do+defCompileBasicOp (Pattern [] [pe]) (ArrayLit es _)+ | Just vs@(v:_) <- mapM isLiteral es = do+ dest_mem <- entryArrayLocation <$> lookupArray (patElemName pe) dest_space <- entryMemSpace <$> lookupMemory (memLocationName dest_mem) let t = primValueType v static_array <- newVName "static_array"@@ -714,11 +727,11 @@ IxFun.iota [fromIntegral $ length es] num_bytes = Imp.ConstSize $ fromIntegral (length es) * primByteSize t entry = MemVar Nothing $ MemEntry num_bytes dest_space- local (insertInVtable static_array entry) $- copy t dest_mem static_src $ fromIntegral $ length es+ addVar static_array entry+ copy t dest_mem static_src $ fromIntegral $ length es | otherwise = forM_ (zip [0..] es) $ \(i,e) ->- copyDWIMDest dest [constIndex i] e []+ copyDWIM (patElemName pe) [constIndex i] e [] where isLiteral (Constant v) = Just v isLiteral _ = Nothing@@ -735,153 +748,58 @@ defCompileBasicOp _ Repeat{} = return () -defCompileBasicOp (Destination _ dests) (Partition n flags value_arrs)- | (sizedests, arrdest) <- splitAt n dests,- Just sizenames <- mapM fromScalarDestination sizedests,- Just destlocs <- mapM arrDestLoc arrdest = do- i <- newVName "i"- declaringLoopVar i Int32 $ do- outer_dim <- compileSubExp =<< (arraySize 0 <$> lookupType flags)- -- We will use 'i' to index the flag array and the value array.- -- Note that they have the same outer size ('outer_dim').- read_flags_i <- readFromArray flags [varIndex i]-- -- First, for each of the 'n' output arrays, we compute the final- -- size. This is done by iterating through the flag array, but- -- first we declare scalars to hold the size. We do this by- -- creating a mapping from equivalence classes to the name of the- -- scalar holding the size.- let sizes = M.fromList $ zip [0..n-1] sizenames-- -- We initialise ecah size to zero.- forM_ sizenames $ \sizename ->- emit $ Imp.SetScalar sizename 0-- -- Now iterate across the flag array, storing each element in- -- 'eqclass', then comparing it to the known classes and increasing- -- the appropriate size variable.- eqclass <- newVName "eqclass"- emit $ Imp.DeclareScalar eqclass int32- let mkSizeLoopBody code c sizevar =- Imp.If (Imp.CmpOpExp (CmpEq int32) (Imp.var eqclass int32) (fromIntegral c))- (Imp.SetScalar sizevar $ Imp.var sizevar int32 + 1)- code- sizeLoopBody = M.foldlWithKey' mkSizeLoopBody Imp.Skip sizes- emit $ Imp.For i Int32 outer_dim $- Imp.SetScalar eqclass read_flags_i <>- sizeLoopBody-- -- We can now compute the starting offsets of each of the- -- partitions, creating a map from equivalence class to its- -- corresponding offset.- offsets <- flip evalStateT 0 $ forM sizes $ \size -> do- cur_offset <- get- partition_offset <- lift $ newVName "partition_offset"- lift $ emit $ Imp.DeclareScalar partition_offset int32- lift $ emit $ Imp.SetScalar partition_offset cur_offset- put $ Imp.var partition_offset int32 + Imp.var size int32- return partition_offset-- -- We create the memory location we use when writing a result- -- element. This is basically the index function of 'destloc', but- -- with a dynamic offset, stored in 'partition_cur_offset'.- partition_cur_offset <- newVName "partition_cur_offset"- emit $ Imp.DeclareScalar partition_cur_offset int32-- -- Finally, we iterate through the data array and flag array in- -- parallel, and put each element where it is supposed to go. Note- -- that after writing to a partition, we increase the corresponding- -- offset.- ets <- mapM (fmap elemType . lookupType) value_arrs- srclocs <- mapM arrayLocation value_arrs- copy_elements <- forM (zip3 destlocs ets srclocs) $ \(destloc,et,srcloc) ->- copyArrayDWIM et- destloc [varIndex partition_cur_offset]- srcloc [varIndex i]- let mkWriteLoopBody code c offsetvar =- Imp.If (Imp.CmpOpExp (CmpEq int32) (Imp.var eqclass int32) (fromIntegral c))- (Imp.SetScalar partition_cur_offset- (Imp.var offsetvar int32)- <>- mconcat copy_elements- <>- Imp.SetScalar offsetvar- (Imp.var offsetvar int32 + 1))- code- writeLoopBody = M.foldlWithKey' mkWriteLoopBody Imp.Skip offsets- emit $ Imp.For i Int32 outer_dim $- Imp.SetScalar eqclass read_flags_i <>- writeLoopBody- return ()- where arrDestLoc (ArrayDestination destloc) = destloc- arrDestLoc _ = Nothing--defCompileBasicOp (Destination _ []) _ = return () -- No arms, no cake.--defCompileBasicOp target e =- compilerBugS $ "ImpGen.defCompileBasicOp: Invalid target\n " ++- show target ++ "\nfor expression\n " ++ pretty e--writeExp :: ValueDestination -> Imp.Exp -> ImpM lore op ()-writeExp (ScalarDestination target) e =- emit $ Imp.SetScalar target e-writeExp (ArrayElemDestination destmem bt space elemoffset) e = do- vol <- asks envVolatility- emit $ Imp.Write destmem elemoffset bt space vol e-writeExp target e =- compilerBugS $ "Cannot write " ++ pretty e ++ " to " ++ show target--insertInVtable :: VName -> VarEntry lore -> Env lore op -> Env lore op-insertInVtable name entry env =- env { envVtable = M.insert name entry $ envVtable env }--withArray :: ArrayDecl -> ImpM lore op a -> ImpM lore op a-withArray (ArrayDecl name bt location) m = do- let entry = ArrayVar Nothing ArrayEntry- { entryArrayLocation = location- , entryArrayElemType = bt- }- local (insertInVtable name entry) m+defCompileBasicOp pat e =+ compilerBugS $ "ImpGen.defCompileBasicOp: Invalid pattern\n " +++ pretty pat ++ "\nfor expression\n " ++ pretty e -withArrays :: [ArrayDecl] -> ImpM lore op a -> ImpM lore op a-withArrays = flip $ foldr withArray+-- | Note: a hack to be used only for functions.+addArrays :: [ArrayDecl] -> ImpM lore op ()+addArrays = mapM_ addArray+ where addArray (ArrayDecl name bt location) =+ addVar name $+ ArrayVar Nothing ArrayEntry+ { entryArrayLocation = location+ , entryArrayElemType = bt+ } --- | Like 'declaringFParams', but does not create new declarations.-withFParams :: ExplicitMemorish lore => [FParam lore] -> ImpM lore op a -> ImpM lore op a-withFParams = flip $ foldr withFParam- where withFParam fparam m = do+-- | Like 'daringFParams', but does not create new declarations.+-- Note: a hack to be used only for functions.+addFParams :: ExplicitMemorish lore => [FParam lore] -> ImpM lore op ()+addFParams = mapM_ addFParam+ where addFParam fparam = do entry <- memBoundToVarEntry Nothing $ noUniquenessReturns $ paramAttr fparam- local (insertInVtable (paramName fparam) entry) m+ addVar (paramName fparam) entry -declaringVars :: ExplicitMemorish lore =>- Maybe (Exp lore) -> [PatElem lore] -> ImpM lore op a -> ImpM lore op a-declaringVars e = flip $ foldr declaringVar- where declaringVar = declaringScope e . scopeOfPatElem+-- | Another hack.+addLoopVar :: VName -> IntType -> ImpM lore op ()+addLoopVar i it = addVar i $ ScalarVar Nothing $ ScalarEntry $ IntType it -declaringFParams :: ExplicitMemorish lore => [FParam lore] -> ImpM lore op a -> ImpM lore op a-declaringFParams = declaringScope Nothing . scopeOfFParams+dVars :: ExplicitMemorish lore =>+ Maybe (Exp lore) -> [PatElem lore] -> ImpM lore op ()+dVars e = mapM_ dVar+ where dVar = dScope e . scopeOfPatElem -declaringLParams :: ExplicitMemorish lore => [LParam lore] -> ImpM lore op a -> ImpM lore op a-declaringLParams = declaringScope Nothing . scopeOfLParams+dFParams :: ExplicitMemorish lore => [FParam lore] -> ImpM lore op ()+dFParams = dScope Nothing . scopeOfFParams -declaringVarEntry :: VName -> VarEntry lore -> ImpM lore op a -> ImpM lore op a-declaringVarEntry name entry m = do- case entry of- MemVar _ entry' ->- emit $ Imp.DeclareMem name $ entryMemSpace entry'- ScalarVar _ entry' ->- emit $ Imp.DeclareScalar name $ entryScalarType entry'- ArrayVar _ _ ->- return ()- local (insertInVtable name entry) m+dLParams :: ExplicitMemorish lore => [LParam lore] -> ImpM lore op ()+dLParams = dScope Nothing . scopeOfLParams -declaringPrimVar :: VName -> PrimType -> ImpM lore op a -> ImpM lore op a-declaringPrimVar name bt =- declaringVarEntry name $ ScalarVar Nothing $ ScalarEntry bt+dPrim_ :: VName -> PrimType -> ImpM lore op ()+dPrim_ name t = do+ emit $ Imp.DeclareScalar name t+ addVar name $ ScalarVar Nothing $ ScalarEntry t -declaringPrimVars :: [(VName,PrimType)] -> ImpM lore op a -> ImpM lore op a-declaringPrimVars = flip $ foldr (uncurry declaringPrimVar)+dPrim :: String -> PrimType -> ImpM lore op VName+dPrim name t = do name' <- newVName name+ dPrim_ name' t+ return name' +dPrimV :: String -> Imp.Exp -> ImpM lore op VName+dPrimV name e = do name' <- dPrim name $ primExpType e+ name' <-- e+ return name'+ memBoundToVarEntry :: Maybe (Exp lore) -> MemBound NoUniqueness -> ImpM lore op (VarEntry lore) memBoundToVarEntry e (MemPrim bt) =@@ -898,32 +816,33 @@ , entryArrayElemType = bt } -declaringName :: Maybe (Exp lore) -> VName -> NameInfo ExplicitMemory- -> ImpM lore op a -> ImpM lore op a-declaringName e name info m = do+dInfo :: Maybe (Exp lore) -> VName -> NameInfo ExplicitMemory+ -> ImpM lore op ()+dInfo e name info = do entry <- memBoundToVarEntry e $ infoAttr info- declaringVarEntry name entry m+ case entry of+ MemVar _ entry' ->+ emit $ Imp.DeclareMem name $ entryMemSpace entry'+ ScalarVar _ entry' ->+ emit $ Imp.DeclareScalar name $ entryScalarType entry'+ ArrayVar _ _ ->+ return ()+ addVar name entry where infoAttr (LetInfo attr) = attr infoAttr (FParamInfo attr) = noUniquenessReturns attr infoAttr (LParamInfo attr) = attr infoAttr (IndexInfo it) = MemPrim $ IntType it -declaringScope :: Maybe (Exp lore) -> Scope ExplicitMemory -> ImpM lore op a -> ImpM lore op a-declaringScope e scope m = foldr (uncurry $ declaringName e) m $ M.toList scope--declaringScopes :: [(Maybe (Exp lore), Scope ExplicitMemory)] -> ImpM lore op a -> ImpM lore op a-declaringScopes es_and_scopes m = foldr (uncurry declaringScope) m es_and_scopes--withPrimVar :: VName -> PrimType -> ImpM lore op a -> ImpM lore op a-withPrimVar name bt =- local (insertInVtable name $ ScalarVar Nothing $ ScalarEntry bt)+dScope :: Maybe (Exp lore) -> Scope ExplicitMemory -> ImpM lore op ()+dScope e = mapM_ (uncurry $ dInfo e) . M.toList -declaringLoopVars :: IntType -> [VName] -> ImpM lore op a -> ImpM lore op a-declaringLoopVars it = flip $ foldr (`declaringLoopVar` it)+dScopes :: [(Maybe (Exp lore), Scope ExplicitMemory)] -> ImpM lore op ()+dScopes = mapM_ $ uncurry dScope -declaringLoopVar :: VName -> IntType -> ImpM lore op a -> ImpM lore op a-declaringLoopVar name it =- withPrimVar name $ IntType it+dArray :: VName -> PrimType -> ShapeBase SubExp -> MemBind -> ImpM lore op ()+dArray name bt shape membind = do+ entry <- memBoundToVarEntry Nothing $ MemArray bt shape NoUniqueness membind+ addVar name entry everythingVolatile :: ImpM lore op a -> ImpM lore op a everythingVolatile = local $ \env -> env { envVolatility = Imp.Volatile }@@ -934,8 +853,6 @@ concat <$> mapM funcallTarget dests where funcallTarget (ScalarDestination name) = return [name]- funcallTarget ArrayElemDestination{} =- compilerBugS "Cannot put scalar function return in-place yet." -- FIXME funcallTarget (ArrayDestination _) = return [] funcallTarget (MemoryDestination name) =@@ -951,8 +868,8 @@ subExpToDimSize Constant{} = compilerBugS "Size subexp is not an int32 or int64 constant." -compileSubExpTo :: ValueDestination -> SubExp -> ImpM lore op ()-compileSubExpTo dest se = copyDWIMDest dest [] se []+compileSubExpTo :: VName -> SubExp -> ImpM lore op ()+compileSubExpTo d se = copyDWIM d [] se [] compileSubExp :: SubExp -> ImpM lore op Imp.Exp compileSubExp (Constant v) =@@ -976,9 +893,30 @@ constIndex :: Int -> Imp.Exp constIndex = fromIntegral +addVar :: VName -> VarEntry lore -> ImpM lore op ()+addVar name entry =+ modify $ \s -> s { stateVTable = M.insert name entry $ stateVTable s }++-- | Get the current symbol table.+getVTable :: ImpM lore op (VTable lore)+getVTable = gets stateVTable++putVTable :: VTable lore -> ImpM lore op ()+putVTable vtable = modify $ \s -> s { stateVTable = vtable }++-- | Run an action with a modified symbol table. All changes to the+-- symbol table will be reverted once the action is done!+localVTable :: (VTable lore -> VTable lore) -> ImpM lore op a -> ImpM lore op a+localVTable f m = do+ old_vtable <- getVTable+ putVTable $ f old_vtable+ a <- m+ putVTable old_vtable+ return a+ lookupVar :: VName -> ImpM lore op (VarEntry lore) lookupVar name = do- res <- asks $ M.lookup name . envVtable+ res <- gets $ M.lookup name . stateVTable case res of Just entry -> return entry _ -> compilerBugS $ "Unknown variable: " ++ pretty name@@ -990,9 +928,6 @@ ArrayVar _ entry -> return entry _ -> compilerBugS $ "ImpGen.lookupArray: not an array: " ++ pretty name -arrayLocation :: VName -> ImpM lore op MemLocation-arrayLocation name = entryArrayLocation <$> lookupArray name- lookupMemory :: VName -> ImpM lore op MemEntry lookupMemory name = do res <- lookupVar name@@ -1000,19 +935,6 @@ MemVar _ entry -> return entry _ -> compilerBugS $ "Unknown memory block: " ++ pretty name -destinationFromParam :: Param (MemBound u) -> ImpM lore op ValueDestination-destinationFromParam param- | MemArray _ shape _ (ArrayIn mem ixfun) <- paramAttr param = do- let dims = shapeDims shape- memloc <- MemLocation mem <$> mapM subExpToDimSize dims <*>- pure (fmap compilePrimExp ixfun)- return $ ArrayDestination $ Just memloc- | otherwise =- return $ ScalarDestination $ paramName param--destinationFromParams :: [Param (MemBound u)] -> ImpM lore op Destination-destinationFromParams ps = fmap (Destination $ baseTag . paramName <$> maybeHead ps) . mapM destinationFromParam $ ps- destinationFromPattern :: ExplicitMemorish lore => Pattern lore -> ImpM lore op Destination destinationFromPattern pat = fmap (Destination (baseTag <$> maybeHead (patternNames pat))) . mapM inspect $ patternElements pat@@ -1045,15 +967,6 @@ return (mem, space, bytes $ IxFun.index ixfun indices $ primByteSize bt) -readFromArray :: VName -> [Imp.Exp]- -> ImpM lore op Imp.Exp-readFromArray name indices = do- arr <- lookupArray name- (mem, space, i) <-- fullyIndexArray' (entryArrayLocation arr) indices $ entryArrayElemType arr- vol <- asks envVolatility- return $ Imp.index mem i (entryArrayElemType arr) space vol- sliceArray :: MemLocation -> Slice Imp.Exp -> MemLocation@@ -1090,9 +1003,9 @@ -- More complicated read/write operations that use index functions. copy :: CopyCompiler lore op-copy bt dest src n = do+copy bt pat src n = do cc <- asks envCopyCompiler- cc bt dest src n+ cc bt pat src n -- | Use an 'Imp.Copy' if possible, otherwise 'copyElementWise'. defaultCopy :: CopyCompiler lore op@@ -1121,17 +1034,16 @@ copyElementWise :: CopyCompiler lore op copyElementWise bt (MemLocation destmem _ destIxFun) (MemLocation srcmem srcshape srcIxFun) n = do is <- replicateM (IxFun.rank destIxFun) (newVName "i")- declaringLoopVars Int32 is $ do- let ivars = map varIndex is- destidx = IxFun.index destIxFun ivars bt_size- srcidx = IxFun.index srcIxFun ivars bt_size- bounds = map innerExp $ n : drop 1 (map Imp.dimSizeToExp srcshape)- srcspace <- entryMemSpace <$> lookupMemory srcmem- destspace <- entryMemSpace <$> lookupMemory destmem- vol <- asks envVolatility- emit $ foldl (.) id (zipWith (`Imp.For` Int32) is bounds) $- Imp.Write destmem (bytes destidx) bt destspace vol $- Imp.index srcmem (bytes srcidx) bt srcspace vol+ let ivars = map varIndex is+ destidx = IxFun.index destIxFun ivars bt_size+ srcidx = IxFun.index srcIxFun ivars bt_size+ bounds = map innerExp $ n : drop 1 (map Imp.dimSizeToExp srcshape)+ srcspace <- entryMemSpace <$> lookupMemory srcmem+ destspace <- entryMemSpace <$> lookupMemory destmem+ vol <- asks envVolatility+ emit $ foldl (.) id (zipWith (`Imp.For` Int32) is bounds) $+ Imp.Write destmem (bytes destidx) bt destspace vol $+ Imp.index srcmem (bytes srcidx) bt srcspace vol where bt_size = primByteSize bt -- | Copy from here to there; both destination and source may be@@ -1174,13 +1086,10 @@ copyDWIMDest _ _ (Constant v) (_:_) = compilerBugS $ unwords ["copyDWIMDest: constant source", pretty v, "cannot be indexed."]-copyDWIMDest dest dest_is (Constant v) [] =- case dest of+copyDWIMDest pat dest_is (Constant v) [] =+ case pat of ScalarDestination name -> emit $ Imp.SetScalar name $ Imp.ValueExp v- ArrayElemDestination dest_mem _ dest_space dest_i -> do- vol <- asks envVolatility- emit $ Imp.Write dest_mem dest_i bt dest_space vol $ Imp.ValueExp v MemoryDestination{} -> compilerBugS $ unwords ["copyDWIMDest: constant source", pretty v, "cannot be written to memory destination."]@@ -1226,30 +1135,6 @@ vol <- asks envVolatility emit $ Imp.SetScalar name $ Imp.index mem i bt space vol - (ArrayElemDestination{}, _) | not $ null dest_is->- compilerBugS $- unwords ["copyDWIMDest: array elemenent destination given indices:", pretty dest_is]-- (ArrayElemDestination dest_mem _ dest_space dest_i,- ScalarVar _ (ScalarEntry bt)) -> do- vol <- asks envVolatility- emit $ Imp.Write dest_mem dest_i bt dest_space vol $ Imp.var src bt-- (ArrayElemDestination dest_mem _ dest_space dest_i, ArrayVar _ src_arr)- | length (entryArrayShape src_arr) == length src_is -> do- let bt = entryArrayElemType src_arr- (src_mem, src_space, src_i) <-- fullyIndexArray' (entryArrayLocation src_arr) src_is bt- vol <- asks envVolatility- emit $ Imp.Write dest_mem dest_i bt dest_space vol $- Imp.index src_mem src_i bt src_space vol-- (ArrayElemDestination{}, ArrayVar{}) ->- compilerBugS $- unwords ["copyDWIMDest: array element destination, but array source",- pretty src,- "with incomplete indexing."]- (ArrayDestination (Just dest_loc), ArrayVar _ src_arr) -> do let src_loc = entryArrayLocation src_arr bt = entryArrayElemType src_arr@@ -1285,16 +1170,17 @@ MemoryDestination dest copyDWIMDest dest_target dest_is src src_is --- | @compileAlloc dest size space@ allocates @n@ bytes of memory in @space@,+-- | @compileAlloc pat size space@ allocates @n@ bytes of memory in @space@, -- writing the result to @dest@, which must be a single -- 'MemoryDestination',-compileAlloc :: Destination -> SubExp -> Space+compileAlloc :: ExplicitMemorish lore =>+ Pattern lore -> SubExp -> Space -> ImpM lore op ()-compileAlloc (Destination _ [MemoryDestination mem]) e space = do+compileAlloc (Pattern [] [mem]) e space = do e' <- compileSubExp e- emit $ Imp.Allocate mem (Imp.bytes e') space-compileAlloc dest _ _ =- compilerBugS $ "compileAlloc: Invalid destination: " ++ show dest+ emit $ Imp.Allocate (patElemName mem) (Imp.bytes e') space+compileAlloc pat _ _ =+ compilerBugS $ "compileAlloc: Invalid pattern: " ++ pretty pat dimSizeToSubExp :: Imp.Size -> SubExp dimSizeToSubExp (Imp.ConstSize n) = constant n@@ -1302,3 +1188,67 @@ dimSizeToExp :: Imp.Size -> Imp.Exp dimSizeToExp = compilePrimExp . primExpFromSubExp int32 . dimSizeToSubExp++--- Building blocks for constructing code.++sFor :: VName -> IntType -> Imp.Exp -> ImpM lore op () -> ImpM lore op ()+sFor i it bound body = do+ addLoopVar i it+ body' <- collect body+ emit $ Imp.For i it bound body'++sWhile :: Imp.Exp -> ImpM lore op () -> ImpM lore op ()+sWhile cond body = do+ body' <- collect body+ emit $ Imp.While cond body'++sComment :: String -> ImpM lore op () -> ImpM lore op ()+sComment s code = do+ code' <- collect code+ emit $ Imp.Comment s code'++sIf :: Imp.Exp -> ImpM lore op () -> ImpM lore op () -> ImpM lore op ()+sIf cond tbranch fbranch = do+ tbranch' <- collect tbranch+ fbranch' <- collect fbranch+ emit $ Imp.If cond tbranch' fbranch'++sWhen :: Imp.Exp -> ImpM lore op () -> ImpM lore op ()+sWhen cond tbranch = sIf cond tbranch (return ())++sUnless :: Imp.Exp -> ImpM lore op () -> ImpM lore op ()+sUnless cond = sIf cond (return ())++sOp :: op -> ImpM lore op ()+sOp = emit . Imp.Op++sAlloc :: String -> Count Bytes -> Space -> ImpM lore op VName+sAlloc name size space = do+ name' <- newVName name+ size' <- case Imp.innerExp size of+ Imp.LeafExp (Imp.ScalarVar size') _ -> return $ Imp.VarSize size'+ Imp.ValueExp (IntValue (Int64Value v)) -> return $ Imp.ConstSize v+ _ -> do size_var <- dPrim "local_buf_size" int32+ size_var <-- Imp.innerExp size+ return $ Imp.VarSize size_var+ emit $ Imp.DeclareMem name' space+ emit $ Imp.Allocate name' size space+ addVar name' $ MemVar Nothing $ MemEntry size' space+ return name'++sArray :: String -> PrimType -> ShapeBase SubExp -> MemBind -> ImpM lore op VName+sArray name bt shape membind = do+ name' <- newVName name+ dArray name' bt shape membind+ return name'++sWrite :: VName -> [Imp.Exp] -> PrimExp Imp.ExpLeaf -> ImpM lore op ()+sWrite arr is v = do+ (mem, space, offset) <- fullyIndexArray arr is+ vol <- asks envVolatility+ emit $ Imp.Write mem offset (primExpType v) space vol v++-- | ASsignment.+(<--) :: VName -> Imp.Exp -> ImpM lore op ()+x <-- e = emit $ Imp.SetScalar x e+infixl 3 <--
src/Futhark/CodeGen/ImpGen/Kernels.hs view
@@ -26,1346 +26,1305 @@ import qualified Futhark.CodeGen.ImpCode.Kernels as Imp import Futhark.CodeGen.ImpCode.Kernels (bytes) import qualified Futhark.CodeGen.ImpGen as ImpGen-import qualified Futhark.Representation.ExplicitMemory.IndexFunction as IxFun-import Futhark.CodeGen.SetDefaultSpace-import Futhark.Tools (partitionChunkedKernelLambdaParameters, fullSliceNum)-import Futhark.Util.IntegralExp (quotRoundingUp, quot, rem, IntegralExp)-import Futhark.Util (splitAt3)--type CallKernelGen = ImpGen.ImpM ExplicitMemory Imp.HostOp-type InKernelGen = ImpGen.ImpM InKernel Imp.KernelOp--callKernelOperations :: ImpGen.Operations ExplicitMemory Imp.HostOp-callKernelOperations =- ImpGen.Operations { ImpGen.opsExpCompiler = expCompiler- , ImpGen.opsCopyCompiler = callKernelCopy- , ImpGen.opsOpCompiler = opCompiler- , ImpGen.opsBodyCompiler = ImpGen.defCompileBody- }--inKernelOperations :: KernelConstants -> ImpGen.Operations InKernel Imp.KernelOp-inKernelOperations constants = (ImpGen.defaultOperations $ compileInKernelOp constants)- { ImpGen.opsCopyCompiler = inKernelCopy- , ImpGen.opsExpCompiler = inKernelExpCompiler- , ImpGen.opsBodyCompiler = compileNestedKernelBody constants- }--compileProg :: MonadFreshNames m => Prog ExplicitMemory -> m (Either InternalError Imp.Program)-compileProg prog =- fmap (setDefaultSpace (Imp.Space "device")) <$>- ImpGen.compileProg callKernelOperations (Imp.Space "device") prog--opCompiler :: ImpGen.Destination -> Op ExplicitMemory- -> CallKernelGen ()-opCompiler dest (Alloc e space) =- ImpGen.compileAlloc dest e space-opCompiler dest (Inner kernel) =- kernelCompiler dest kernel--compileInKernelOp :: KernelConstants -> ImpGen.Destination -> Op InKernel- -> InKernelGen ()-compileInKernelOp _ (ImpGen.Destination _ [ImpGen.MemoryDestination mem]) Alloc{} =- compilerLimitationS $ "Cannot allocate memory block " ++ pretty mem ++ " in kernel."-compileInKernelOp _ dest Alloc{} =- compilerBugS $ "Invalid target for in-kernel allocation: " ++ show dest-compileInKernelOp constants dest (Inner op) =- compileKernelExp constants dest op---- | Recognise kernels (maps), give everything else back.-kernelCompiler :: ImpGen.Destination -> Kernel InKernel- -> CallKernelGen ()--kernelCompiler dest (GetSize key size_class) = do- [v] <- ImpGen.funcallTargets dest- ImpGen.emit $ Imp.Op $ Imp.GetSize v key size_class--kernelCompiler dest (CmpSizeLe key size_class x) = do- [v] <- ImpGen.funcallTargets dest- ImpGen.emit =<< Imp.Op . Imp.CmpSizeLe v key size_class <$> ImpGen.compileSubExp x--kernelCompiler dest (GetSizeMax size_class) = do- [v] <- ImpGen.funcallTargets dest- ImpGen.emit $ Imp.Op $ Imp.GetSizeMax v size_class--kernelCompiler dest (Kernel desc space _ kernel_body) = do-- num_groups' <- ImpGen.subExpToDimSize $ spaceNumGroups space- group_size' <- ImpGen.subExpToDimSize $ spaceGroupSize space- num_threads' <- ImpGen.subExpToDimSize $ spaceNumThreads space-- let bound_in_kernel =- M.keys $- scopeOfKernelSpace space <>- scopeOf (kernelBodyStms kernel_body)-- let global_tid = spaceGlobalId space- local_tid = spaceLocalId space- group_id = spaceGroupId space- wave_size <- newVName "wave_size"- inner_group_size <- newVName "group_size"- thread_active <- newVName "thread_active"-- let (space_is, space_dims) = unzip $ spaceDimensions space- space_dims' <- mapM ImpGen.compileSubExp space_dims- let constants = KernelConstants global_tid local_tid group_id- group_size' num_threads'- (Imp.VarSize wave_size) (zip space_is space_dims')- (Imp.var thread_active Bool) mempty-- kernel_body' <-- makeAllMemoryGlobal $- ImpGen.subImpM_ (inKernelOperations constants) $- ImpGen.declaringPrimVar wave_size int32 $- ImpGen.declaringPrimVar inner_group_size int32 $- ImpGen.declaringPrimVar thread_active Bool $- ImpGen.declaringScope Nothing (scopeOfKernelSpace space) $ do-- ImpGen.emit $- Imp.Op (Imp.GetGlobalId global_tid 0) <>- Imp.Op (Imp.GetLocalId local_tid 0) <>- Imp.Op (Imp.GetLocalSize inner_group_size 0) <>- Imp.Op (Imp.GetLockstepWidth wave_size) <>- Imp.Op (Imp.GetGroupId group_id 0)-- setSpaceIndices space-- ImpGen.emit $ Imp.SetScalar thread_active (isActive $ spaceDimensions space)-- compileKernelBody dest constants kernel_body-- (uses, local_memory) <- computeKernelUses kernel_body' bound_in_kernel-- forM_ (kernelHints desc) $ \(s,v) -> do- ty <- case v of- Constant pv -> return $ Prim $ primValueType pv- Var vn -> lookupType vn- unless (primType ty) $ fail $ concat [ "debugKernelHint '", s, "'"- , " in kernel '", kernelName desc, "'"- , " did not have primType value." ]-- ImpGen.compileSubExp v >>= ImpGen.emit . Imp.DebugPrint s (elemType ty)-- ImpGen.emit $ Imp.Op $ Imp.CallKernel $ Imp.AnyKernel Imp.Kernel- { Imp.kernelBody = kernel_body'- , Imp.kernelLocalMemory = local_memory- , Imp.kernelUses = uses- , Imp.kernelNumGroups = num_groups'- , Imp.kernelGroupSize = group_size'- , Imp.kernelName = global_tid- , Imp.kernelDesc = kernelName desc- }--expCompiler :: ImpGen.ExpCompiler ExplicitMemory Imp.HostOp--- We generate a simple kernel for itoa and replicate.-expCompiler- (ImpGen.Destination tag [ImpGen.ArrayDestination (Just destloc)])- (BasicOp (Iota n x s et)) = do- thread_gid <- maybe (newVName "thread_gid") (return . VName (nameFromString "thread_gid")) tag-- makeAllMemoryGlobal $ do- (destmem, destspace, destidx) <-- ImpGen.fullyIndexArray' destloc [ImpGen.varIndex thread_gid] (IntType et)-- n' <- ImpGen.compileSubExp n- x' <- ImpGen.compileSubExp x- s' <- ImpGen.compileSubExp s-- let body = Imp.Write destmem destidx (IntType et) destspace Imp.Nonvolatile $- Imp.ConvOpExp (SExt Int32 et) (Imp.var thread_gid int32) * s' + x'-- (group_size, num_groups) <- computeMapKernelGroups n'-- (body_uses, _) <- computeKernelUses- (freeIn body <> freeIn [n',x',s'])- [thread_gid]-- ImpGen.emit $ Imp.Op $ Imp.CallKernel $ Imp.Map Imp.MapKernel- { Imp.mapKernelThreadNum = thread_gid- , Imp.mapKernelDesc = "iota"- , Imp.mapKernelNumGroups = Imp.VarSize num_groups- , Imp.mapKernelGroupSize = Imp.VarSize group_size- , Imp.mapKernelSize = n'- , Imp.mapKernelUses = body_uses- , Imp.mapKernelBody = body- }--expCompiler- (ImpGen.Destination tag [dest]) (BasicOp (Replicate (Shape ds) se)) = do- constants <- simpleKernelConstants tag "replicate"-- t <- subExpType se- let thread_gid = kernelGlobalThreadId constants- row_dims = arrayDims t- dims = ds ++ row_dims- is' = unflattenIndex (map (ImpGen.compileSubExpOfType int32) dims) $- ImpGen.varIndex thread_gid- ds' <- mapM ImpGen.compileSubExp ds-- makeAllMemoryGlobal $ do- body <- ImpGen.subImpM_ (inKernelOperations constants) $- ImpGen.copyDWIMDest dest is' se $ drop (length ds) is'-- dims' <- mapM ImpGen.compileSubExp dims- (group_size, num_groups) <- computeMapKernelGroups $ product dims'-- (body_uses, _) <- computeKernelUses- (freeIn body <> freeIn ds')- [thread_gid]-- ImpGen.emit $ Imp.Op $ Imp.CallKernel $ Imp.Map Imp.MapKernel- { Imp.mapKernelThreadNum = thread_gid- , Imp.mapKernelDesc = "replicate"- , Imp.mapKernelNumGroups = Imp.VarSize num_groups- , Imp.mapKernelGroupSize = Imp.VarSize group_size- , Imp.mapKernelSize = product dims'- , Imp.mapKernelUses = body_uses- , Imp.mapKernelBody = body- }---- Allocation in the "local" space is just a placeholder.-expCompiler _ (Op (Alloc _ (Space "local"))) =- return ()--expCompiler dest e =- ImpGen.defCompileExp dest e--callKernelCopy :: ImpGen.CopyCompiler ExplicitMemory Imp.HostOp-callKernelCopy bt- destloc@(ImpGen.MemLocation destmem destshape destIxFun)- srcloc@(ImpGen.MemLocation srcmem srcshape srcIxFun)- n- | Just (destoffset, srcoffset,- num_arrays, size_x, size_y,- src_elems, dest_elems) <- isMapTransposeKernel bt destloc srcloc =- ImpGen.emit $ Imp.Op $ Imp.CallKernel $- Imp.MapTranspose bt- destmem destoffset- srcmem srcoffset- num_arrays size_x size_y- src_elems dest_elems-- | bt_size <- primByteSize bt,- ixFunMatchesInnerShape- (Shape $ map Imp.sizeToExp destshape) destIxFun,- ixFunMatchesInnerShape- (Shape $ map Imp.sizeToExp srcshape) srcIxFun,- Just destoffset <-- IxFun.linearWithOffset destIxFun bt_size,- Just srcoffset <-- IxFun.linearWithOffset srcIxFun bt_size = do- let row_size = product $ map ImpGen.dimSizeToExp $ drop 1 srcshape- srcspace <- ImpGen.entryMemSpace <$> ImpGen.lookupMemory srcmem- destspace <- ImpGen.entryMemSpace <$> ImpGen.lookupMemory destmem- ImpGen.emit $ Imp.Copy- destmem (bytes destoffset) destspace- srcmem (bytes srcoffset) srcspace $- (n * row_size) `Imp.withElemType` bt-- | otherwise = do- global_thread_index <- newVName "copy_global_thread_index"-- -- Note that the shape of the destination and the source are- -- necessarily the same.- let shape = map Imp.sizeToExp srcshape- shape_se = map (Imp.innerExp . ImpGen.dimSizeToExp) srcshape- dest_is = unflattenIndex shape_se $ ImpGen.varIndex global_thread_index- src_is = dest_is-- makeAllMemoryGlobal $ do- (_, destspace, destidx) <- ImpGen.fullyIndexArray' destloc dest_is bt- (_, srcspace, srcidx) <- ImpGen.fullyIndexArray' srcloc src_is bt-- let body = Imp.Write destmem destidx bt destspace Imp.Nonvolatile $- Imp.index srcmem srcidx bt srcspace Imp.Nonvolatile-- destmem_size <- ImpGen.entryMemSize <$> ImpGen.lookupMemory destmem- let writes_to = [Imp.MemoryUse destmem destmem_size]-- reads_from <- readsFromSet $- S.singleton srcmem <>- freeIn destIxFun <> freeIn srcIxFun <> freeIn destshape-- let kernel_size = Imp.innerExp n * product (drop 1 shape)- (group_size, num_groups) <- computeMapKernelGroups kernel_size-- let bound_in_kernel = [global_thread_index]- (body_uses, _) <- computeKernelUses (kernel_size, body) bound_in_kernel-- ImpGen.emit $ Imp.Op $ Imp.CallKernel $ Imp.Map Imp.MapKernel- { Imp.mapKernelThreadNum = global_thread_index- , Imp.mapKernelDesc = "copy"- , Imp.mapKernelNumGroups = Imp.VarSize num_groups- , Imp.mapKernelGroupSize = Imp.VarSize group_size- , Imp.mapKernelSize = kernel_size- , Imp.mapKernelUses = nub $ body_uses ++ writes_to ++ reads_from- , Imp.mapKernelBody = body- }---- | We have no bulk copy operation (e.g. memmove) inside kernels, so--- turn any copy into a loop.-inKernelCopy :: ImpGen.CopyCompiler InKernel Imp.KernelOp-inKernelCopy = ImpGen.copyElementWise--inKernelExpCompiler :: ImpGen.ExpCompiler InKernel Imp.KernelOp-inKernelExpCompiler _ (BasicOp (Assert _ _ (loc, locs))) =- compilerLimitationS $- unlines [ "Cannot compile assertion at " ++- intercalate " -> " (reverse $ map locStr $ loc:locs) ++- " inside parallel kernel."- , "As a workaround, surround the expression with 'unsafe'."]--- The static arrays stuff does not work inside kernels.-inKernelExpCompiler (ImpGen.Destination _ [dest]) (BasicOp (ArrayLit es _)) =- forM_ (zip [0..] es) $ \(i,e) ->- ImpGen.copyDWIMDest dest [fromIntegral (i::Int32)] e []-inKernelExpCompiler dest e =- ImpGen.defCompileExp dest e--computeKernelUses :: FreeIn a =>- a -> [VName]- -> CallKernelGen ([Imp.KernelUse], [Imp.LocalMemoryUse])-computeKernelUses kernel_body bound_in_kernel = do- let actually_free = freeIn kernel_body `S.difference` S.fromList bound_in_kernel-- -- Compute the variables that we need to pass to the kernel.- reads_from <- readsFromSet actually_free-- -- Are we using any local memory?- local_memory <- computeLocalMemoryUse actually_free- return (nub reads_from, nub local_memory)--readsFromSet :: Names -> CallKernelGen [Imp.KernelUse]-readsFromSet free =- fmap catMaybes $- forM (S.toList free) $ \var -> do- t <- lookupType var- case t of- Array {} -> return Nothing- Mem _ (Space "local") -> return Nothing- Mem memsize _ -> Just <$> (Imp.MemoryUse var <$>- ImpGen.subExpToDimSize memsize)- Prim bt ->- isConstExp var >>= \case- Just ce -> return $ Just $ Imp.ConstUse var ce- Nothing | bt == Cert -> return Nothing- | otherwise -> return $ Just $ Imp.ScalarUse var bt--computeLocalMemoryUse :: Names -> CallKernelGen [Imp.LocalMemoryUse]-computeLocalMemoryUse free =- fmap catMaybes $- forM (S.toList free) $ \var -> do- t <- lookupType var- case t of- Mem memsize (Space "local") -> do- memsize' <- localMemSize =<< ImpGen.subExpToDimSize memsize- return $ Just (var, memsize')- _ -> return Nothing--localMemSize :: Imp.MemSize -> CallKernelGen (Either Imp.MemSize Imp.KernelConstExp)-localMemSize (Imp.ConstSize x) =- return $ Right $ ValueExp $ IntValue $ Int64Value x-localMemSize (Imp.VarSize v) = isConstExp v >>= \case- Just e | isStaticExp e -> return $ Right e- _ -> return $ Left $ Imp.VarSize v---- | Only some constant expressions quality as *static* expressions,--- which we can use for static memory allocation. This is a bit of a--- hack, as it is primarly motivated by what you can put as the size--- when declaring an array in C.-isStaticExp :: Imp.KernelConstExp -> Bool-isStaticExp LeafExp{} = True-isStaticExp ValueExp{} = True-isStaticExp (BinOpExp Add{} x y) = isStaticExp x && isStaticExp y-isStaticExp (BinOpExp Sub{} x y) = isStaticExp x && isStaticExp y-isStaticExp (BinOpExp Mul{} x y) = isStaticExp x && isStaticExp y-isStaticExp _ = False--isConstExp :: VName -> CallKernelGen (Maybe Imp.KernelConstExp)-isConstExp v = do- vtable <- asks ImpGen.envVtable- let lookupConstExp name = constExp =<< hasExp =<< M.lookup name vtable- constExp (Op (Inner (GetSize key _))) = Just $ LeafExp (Imp.SizeConst key) int32- constExp e = primExpFromExp lookupConstExp e- return $ lookupConstExp v- where hasExp (ImpGen.ArrayVar e _) = e- hasExp (ImpGen.ScalarVar e _) = e- hasExp (ImpGen.MemVar e _) = e---- | Change every memory block to be in the global address space,--- except those who are in the local memory space. This only affects--- generated code - we still need to make sure that the memory is--- actually present on the device (and declared as variables in the--- kernel).-makeAllMemoryGlobal :: CallKernelGen a- -> CallKernelGen a-makeAllMemoryGlobal =- local $ \env -> env { ImpGen.envVtable = M.map globalMemory $ ImpGen.envVtable env- , ImpGen.envDefaultSpace = Imp.Space "global"- }- where globalMemory (ImpGen.MemVar _ entry)- | ImpGen.entryMemSpace entry /= Space "local" =- ImpGen.MemVar Nothing entry { ImpGen.entryMemSpace = Imp.Space "global" }- globalMemory entry =- entry--computeMapKernelGroups :: Imp.Exp -> CallKernelGen (VName, VName)-computeMapKernelGroups kernel_size = do- group_size <- newVName "group_size"- num_groups <- newVName "num_groups"- let group_size_var = Imp.var group_size int32- ImpGen.emit $ Imp.DeclareScalar group_size int32- ImpGen.emit $ Imp.DeclareScalar num_groups int32- ImpGen.emit $ Imp.Op $ Imp.GetSize group_size group_size Imp.SizeGroup- ImpGen.emit $ Imp.SetScalar num_groups $- kernel_size `quotRoundingUp` Imp.ConvOpExp (SExt Int32 Int32) group_size_var- return (group_size, num_groups)--isMapTransposeKernel :: PrimType -> ImpGen.MemLocation -> ImpGen.MemLocation- -> Maybe (Imp.Exp, Imp.Exp,- Imp.Exp, Imp.Exp, Imp.Exp,- Imp.Exp, Imp.Exp)-isMapTransposeKernel bt- (ImpGen.MemLocation _ _ destIxFun)- (ImpGen.MemLocation _ _ srcIxFun)- | Just (dest_offset, perm_and_destshape) <- IxFun.rearrangeWithOffset destIxFun bt_size,- (perm, destshape) <- unzip perm_and_destshape,- srcshape' <- IxFun.shape srcIxFun,- Just src_offset <- IxFun.linearWithOffset srcIxFun bt_size,- Just (r1, r2, _) <- isMapTranspose perm =- isOk (product srcshape') (product destshape) destshape swap r1 r2 dest_offset src_offset- | Just dest_offset <- IxFun.linearWithOffset destIxFun bt_size,- Just (src_offset, perm_and_srcshape) <- IxFun.rearrangeWithOffset srcIxFun bt_size,- (perm, srcshape) <- unzip perm_and_srcshape,- destshape' <- IxFun.shape destIxFun,- Just (r1, r2, _) <- isMapTranspose perm =- isOk (product srcshape) (product destshape') srcshape id r1 r2 dest_offset src_offset- | otherwise =- Nothing- where bt_size = primByteSize bt- swap (x,y) = (y,x)-- isOk src_elems dest_elems shape f r1 r2 dest_offset src_offset = do- let (num_arrays, size_x, size_y) = getSizes shape f r1 r2- return (dest_offset, src_offset,- num_arrays, size_x, size_y,- src_elems, dest_elems)-- getSizes shape f r1 r2 =- let (mapped, notmapped) = splitAt r1 shape- (pretrans, posttrans) = f $ splitAt r2 notmapped- in (product mapped, product pretrans, product posttrans)--writeParamToLocalMemory :: Typed (MemBound u) =>- Imp.Exp -> (VName, t) -> Param (MemBound u)- -> ImpGen.ImpM lore op ()-writeParamToLocalMemory i (mem, _) param- | Prim t <- paramType param =- ImpGen.emit $- Imp.Write mem (bytes i') bt (Space "local") Imp.Volatile $- Imp.var (paramName param) t- | otherwise =- return ()- where i' = i * Imp.LeafExp (Imp.SizeOf bt) int32- bt = elemType $ paramType param--readParamFromLocalMemory :: Typed (MemBound u) =>- VName -> Imp.Exp -> Param (MemBound u) -> (VName, t)- -> ImpGen.ImpM lore op ()-readParamFromLocalMemory index i param (l_mem, _)- | Prim _ <- paramType param =- ImpGen.emit $- Imp.SetScalar (paramName param) $- Imp.index l_mem (bytes i') bt (Space "local") Imp.Volatile- | otherwise =- ImpGen.emit $- Imp.SetScalar index i- where i' = i * Imp.LeafExp (Imp.SizeOf bt) int32- bt = elemType $ paramType param--computeThreadChunkSize :: SplitOrdering- -> Imp.Exp- -> Imp.Count Imp.Elements- -> Imp.Count Imp.Elements- -> VName- -> ImpGen.ImpM lore op ()-computeThreadChunkSize (SplitStrided stride) thread_index elements_per_thread num_elements chunk_var = do- stride' <- ImpGen.compileSubExp stride- ImpGen.emit $ Imp.SetScalar chunk_var $ Imp.BinOpExp (SMin Int32)- (Imp.innerExp elements_per_thread) $- (Imp.innerExp num_elements - thread_index)- `quotRoundingUp`- stride'--computeThreadChunkSize SplitContiguous thread_index elements_per_thread num_elements chunk_var = do- starting_point <- newVName "starting_point"- remaining_elements <- newVName "remaining_elements"-- ImpGen.emit $- Imp.DeclareScalar starting_point int32- ImpGen.emit $- Imp.SetScalar starting_point $- thread_index * Imp.innerExp elements_per_thread-- ImpGen.emit $- Imp.DeclareScalar remaining_elements int32- ImpGen.emit $- Imp.SetScalar remaining_elements $- Imp.innerExp num_elements - Imp.var starting_point int32-- let no_remaining_elements = Imp.CmpOpExp (CmpSle Int32)- (Imp.var remaining_elements int32) 0- beyond_bounds = Imp.CmpOpExp (CmpSle Int32)- (Imp.innerExp num_elements)- (Imp.var starting_point int32)-- ImpGen.emit $- Imp.If (Imp.BinOpExp LogOr no_remaining_elements beyond_bounds)- (Imp.SetScalar chunk_var 0)- (Imp.If is_last_thread- (Imp.SetScalar chunk_var $ Imp.innerExp last_thread_elements)- (Imp.SetScalar chunk_var $ Imp.innerExp elements_per_thread))- where last_thread_elements =- num_elements - Imp.elements thread_index * elements_per_thread- is_last_thread =- Imp.CmpOpExp (CmpSlt Int32)- (Imp.innerExp num_elements)- ((thread_index + 1) * Imp.innerExp elements_per_thread)--inBlockScan :: Imp.Exp- -> Imp.Exp- -> Imp.Exp- -> VName- -> [(VName, t)]- -> Lambda InKernel- -> InKernelGen ()-inBlockScan lockstep_width block_size active local_id acc_local_mem scan_lam = ImpGen.everythingVolatile $ do- skip_threads <- newVName "skip_threads"- let in_block_thread_active =- Imp.CmpOpExp (CmpSle Int32) (Imp.var skip_threads int32) in_block_id- (scan_lam_i, other_index_param, actual_params) =- partitionChunkedKernelLambdaParameters $ lambdaParams scan_lam- (x_params, y_params) =- splitAt (length actual_params `div` 2) actual_params- read_operands <-- ImpGen.collect $- zipWithM_ (readParamFromLocalMemory (paramName other_index_param) $- Imp.var local_id int32 - Imp.var skip_threads int32)- x_params acc_local_mem- scan_y_dest <- ImpGen.destinationFromParams y_params-- -- Set initial y values- read_my_initial <- ImpGen.collect $- zipWithM_ (readParamFromLocalMemory scan_lam_i $ Imp.var local_id int32)- y_params acc_local_mem- ImpGen.emit $ Imp.If active read_my_initial mempty-- op_to_y <- ImpGen.collect $ ImpGen.compileBody scan_y_dest $ lambdaBody scan_lam- write_operation_result <-- ImpGen.collect $- zipWithM_ (writeParamToLocalMemory $ Imp.var local_id int32)- acc_local_mem y_params- let andBlockActive = Imp.BinOpExp LogAnd active- maybeBarrier = Imp.If (Imp.CmpOpExp (CmpSle Int32) lockstep_width (Imp.var skip_threads int32))- (Imp.Op Imp.Barrier) mempty-- ImpGen.emit $- Imp.Comment "in-block scan (hopefully no barriers needed)" $- Imp.DeclareScalar skip_threads int32 <>- Imp.SetScalar skip_threads 1 <>- Imp.While (Imp.CmpOpExp (CmpSlt Int32) (Imp.var skip_threads int32) block_size)- (Imp.If (andBlockActive in_block_thread_active)- (Imp.Comment "read operands" read_operands <>- Imp.Comment "perform operation" op_to_y) mempty <>-- maybeBarrier <>-- Imp.If (andBlockActive in_block_thread_active)- (Imp.Comment "write result" write_operation_result) mempty <>- maybeBarrier <>- Imp.SetScalar skip_threads (Imp.var skip_threads int32 * 2))- where block_id = Imp.BinOpExp (SQuot Int32) (Imp.var local_id int32) block_size- in_block_id = Imp.var local_id int32 - block_id * block_size--data KernelConstants = KernelConstants- { kernelGlobalThreadId :: VName- , kernelLocalThreadId :: VName- , kernelGroupId :: VName- , kernelGroupSize :: Imp.DimSize- , _kernelNumThreads :: Imp.DimSize- , kernelWaveSize :: Imp.DimSize- , kernelDimensions :: [(VName, Imp.Exp)]- , kernelThreadActive :: Imp.Exp- , kernelStreamed :: [(VName, Imp.DimSize)]- -- ^ Chunk sizez and their maximum size. Hint- -- for unrolling.- }---- FIXME: wing a KernelConstants structure for use in Replicate--- compilation. This cannot be the best way to do this...-simpleKernelConstants :: MonadFreshNames m =>- Maybe Int -> String- -> m KernelConstants-simpleKernelConstants tag desc = do- thread_gtid <- maybe (newVName $ desc ++ "_gtid")- (return . VName (nameFromString $ desc ++ "_gtid")) tag- thread_ltid <- newVName $ desc ++ "_ltid"- thread_gid <- newVName $ desc ++ "_gid"- return $ KernelConstants- thread_gtid thread_ltid thread_gid- (Imp.ConstSize 0) (Imp.ConstSize 0) (Imp.ConstSize 0)- [] (Imp.ValueExp $ BoolValue True) mempty--compileKernelBody :: ImpGen.Destination- -> KernelConstants- -> KernelBody InKernel- -> InKernelGen ()-compileKernelBody (ImpGen.Destination _ dest) constants kbody =- compileKernelStms constants (stmsToList $ kernelBodyStms kbody) $- zipWithM_ (compileKernelResult constants) dest $- kernelBodyResult kbody--compileNestedKernelBody :: KernelConstants- -> ImpGen.Destination- -> Body InKernel- -> InKernelGen ()-compileNestedKernelBody constants (ImpGen.Destination _ dest) kbody =- compileKernelStms constants (stmsToList $ bodyStms kbody) $- zipWithM_ ImpGen.compileSubExpTo dest $ bodyResult kbody--compileKernelStms :: KernelConstants -> [Stm InKernel]- -> InKernelGen a- -> InKernelGen a-compileKernelStms constants ungrouped_bnds m =- compileGroupedKernelStms' $ groupStmsByGuard constants ungrouped_bnds- where compileGroupedKernelStms' [] = m- compileGroupedKernelStms' ((g, bnds):rest_bnds) =- ImpGen.declaringScopes- (map ((Just . stmExp) &&& (castScope . scopeOf)) bnds) $ do- protect g $ mapM_ compileKernelStm bnds- compileGroupedKernelStms' rest_bnds-- protect Nothing body_m =- body_m- protect (Just (Imp.ValueExp (BoolValue True))) body_m =- body_m- protect (Just g) body_m = do- body <- allThreads constants body_m- ImpGen.emit $ Imp.If g body mempty-- compileKernelStm (Let pat _ e) = do- dest <- ImpGen.destinationFromPattern pat- ImpGen.compileExp dest e--groupStmsByGuard :: KernelConstants- -> [Stm InKernel]- -> [(Maybe Imp.Exp, [Stm InKernel])]-groupStmsByGuard constants bnds =- map collapse $ groupBy sameGuard $ zip (map bindingGuard bnds) bnds- where bindingGuard (Let _ _ Op{}) = Nothing- bindingGuard _ = Just $ kernelThreadActive constants-- sameGuard (g1, _) (g2, _) = g1 == g2-- collapse [] =- (Nothing, [])- collapse l@((g,_):_) =- (g, map snd l)--compileKernelExp :: KernelConstants -> ImpGen.Destination -> KernelExp InKernel- -> InKernelGen ()--compileKernelExp _ (ImpGen.Destination _ dests) (Barrier ses) = do- zipWithM_ ImpGen.compileSubExpTo dests ses- ImpGen.emit $ Imp.Op Imp.Barrier--compileKernelExp _ dest (SplitSpace o w i elems_per_thread)- | ImpGen.Destination _ [ImpGen.ScalarDestination size] <- dest = do- num_elements <- Imp.elements <$> ImpGen.compileSubExp w- i' <- ImpGen.compileSubExp i- elems_per_thread' <- Imp.elements <$> ImpGen.compileSubExp elems_per_thread- computeThreadChunkSize o i' elems_per_thread' num_elements size--compileKernelExp constants dest (Combine (CombineSpace scatter cspace) ts aspace body) = do- -- First we compute how many times we have to iterate to cover- -- cspace with our group size. It is a fairly common case that- -- we statically know that this requires 1 iteration, so we- -- could detect it and not generate a loop in that case.- -- However, it seems to have no impact on performance (an extra- -- conditional jump), so for simplicity we just always generate- -- the loop.- let cspace_dims = map (streamBounded . snd) cspace- num_iters = product cspace_dims `quotRoundingUp`- Imp.sizeToExp (kernelGroupSize constants)-- iter <- newVName "comb_iter"- cid <- newVName "flat_comb_id"-- one_iteration <- ImpGen.collect $- ImpGen.declaringPrimVars (zip (map fst cspace) $ repeat int32) $- ImpGen.declaringPrimVar cid int32 $ do-- -- Compute the *flat* array index.- ImpGen.emit $ Imp.SetScalar cid $- Imp.var iter int32 * Imp.sizeToExp (kernelGroupSize constants) +- Imp.var (kernelLocalThreadId constants) int32-- -- Turn it into a nested array index.- forM_ (zip (map fst cspace) $ unflattenIndex cspace_dims (Imp.var cid int32)) $ \(v, x) ->- ImpGen.emit $ Imp.SetScalar v x-- -- Construct the body. This is mostly about the book-keeping- -- for the scatter-like part.- let (scatter_ws, scatter_ns, _scatter_vs) = unzip3 scatter- scatter_ws_repl = concat $ zipWith replicate scatter_ns scatter_ws- (scatter_dests, normal_dests) =- splitAt (sum scatter_ns) $ ImpGen.valueDestinations dest- (res_is, res_vs, res_normal) =- splitAt3 (sum scatter_ns) (sum scatter_ns) $ bodyResult body- scatter_is = map (pure . DimFix . ImpGen.compileSubExpOfType int32) res_is- scatter_dests_repl = concat $ zipWith replicate scatter_ns scatter_dests- (scatter_dests', normal_dests') <-- case (sequence $ zipWith3 index scatter_is ts scatter_dests_repl,- zipWithM (index local_index) (drop (sum scatter_ns*2) ts) normal_dests) of- (Just x, Just y) -> return (x, y)- _ -> fail "compileKernelExp combine: invalid destination."- body' <- allThreads constants $- ImpGen.compileStms (freeIn $ bodyResult body) (stmsToList $ bodyStms body) $ do-- forM_ (zip4 scatter_ws_repl res_is res_vs scatter_dests') $- \(w, res_i, res_v, scatter_dest) -> do- let res_i' = ImpGen.compileSubExpOfType int32 res_i- w' = ImpGen.compileSubExpOfType int32 w- -- We have to check that 'res_i' is in-bounds wrt. an array of size 'w'.- in_bounds = BinOpExp LogAnd (CmpOpExp (CmpSle Int32) 0 res_i')- (CmpOpExp (CmpSlt Int32) res_i' w')- when_in_bounds <- ImpGen.collect $ ImpGen.compileSubExpTo scatter_dest res_v- ImpGen.emit $ Imp.If in_bounds when_in_bounds mempty-- zipWithM_ ImpGen.compileSubExpTo normal_dests' res_normal-- -- Execute the body if we are within bounds.- ImpGen.emit $- Imp.If (Imp.BinOpExp LogAnd (isActive cspace) (isActive aspace)) body' mempty-- ImpGen.emit $ Imp.For iter Int32 num_iters one_iteration- ImpGen.emit $ Imp.Op Imp.Barrier-- where streamBounded (Var v)- | Just x <- lookup v $ kernelStreamed constants =- Imp.sizeToExp x- streamBounded se = ImpGen.compileSubExpOfType int32 se-- local_index = map (DimFix . ImpGen.varIndex . fst) cspace-- index i t (ImpGen.ArrayDestination (Just loc)) =- let space_dims = map (ImpGen.varIndex . fst) cspace- t_dims = map (ImpGen.compileSubExpOfType int32) $ arrayDims t- in Just $ ImpGen.ArrayDestination $- Just $ ImpGen.sliceArray loc $- fullSliceNum (space_dims++t_dims) i- index _ _ _ = Nothing--compileKernelExp constants (ImpGen.Destination _ dests) (GroupReduce w lam input) = do- skip_waves <- newVName "skip_waves"- w' <- ImpGen.compileSubExp w-- let local_tid = kernelLocalThreadId constants- (_nes, arrs) = unzip input- (reduce_i, reduce_j_param, actual_reduce_params) =- partitionChunkedKernelLambdaParameters $ lambdaParams lam- (reduce_acc_params, reduce_arr_params) =- splitAt (length input) actual_reduce_params- reduce_j = paramName reduce_j_param-- offset <- newVName "offset"- ImpGen.emit $ Imp.DeclareScalar offset int32-- ImpGen.Destination _ reduce_acc_targets <-- ImpGen.destinationFromParams reduce_acc_params-- ImpGen.declaringPrimVar skip_waves int32 $- ImpGen.declaringLParams (lambdaParams lam) $ do-- ImpGen.emit $ Imp.SetScalar reduce_i $ Imp.var local_tid int32-- let setOffset x =- Imp.SetScalar offset x <>- Imp.SetScalar reduce_j (Imp.var local_tid int32 + Imp.var offset int32)- ImpGen.emit $ setOffset 0-- set_init_params <- ImpGen.collect $- zipWithM_ (readReduceArgument offset) reduce_acc_params arrs- ImpGen.emit $- Imp.If (Imp.CmpOpExp (CmpSlt Int32) (Imp.var local_tid int32) w')- set_init_params mempty-- let read_reduce_args = zipWithM_ (readReduceArgument offset)- reduce_arr_params arrs- reduce_acc_dest = ImpGen.Destination Nothing reduce_acc_targets- do_reduce = do ImpGen.comment "read array element" read_reduce_args- ImpGen.compileBody reduce_acc_dest $ lambdaBody lam- zipWithM_ (writeReduceOpResult local_tid)- reduce_acc_params arrs-- in_wave_reduce <- ImpGen.collect $ ImpGen.everythingVolatile do_reduce- cross_wave_reduce <- ImpGen.collect do_reduce-- let wave_size = Imp.sizeToExp $ kernelWaveSize constants- group_size = Imp.sizeToExp $ kernelGroupSize constants- wave_id = Imp.var local_tid int32 `quot` wave_size- in_wave_id = Imp.var local_tid int32 - wave_id * wave_size- num_waves = (group_size + wave_size - 1) `quot` wave_size- arg_in_bounds = Imp.CmpOpExp (CmpSlt Int32)- (Imp.var reduce_j int32) w'-- doing_in_wave_reductions =- Imp.CmpOpExp (CmpSlt Int32) (Imp.var offset int32) wave_size- apply_in_in_wave_iteration =- Imp.CmpOpExp (CmpEq int32)- (Imp.BinOpExp (And Int32) in_wave_id (2 * Imp.var offset int32 - 1)) 0- in_wave_reductions =- setOffset 1 <>- Imp.While doing_in_wave_reductions- (Imp.If (Imp.BinOpExp LogAnd arg_in_bounds apply_in_in_wave_iteration)- in_wave_reduce mempty <>- setOffset (Imp.var offset int32 * 2))-- doing_cross_wave_reductions =- Imp.CmpOpExp (CmpSlt Int32) (Imp.var skip_waves int32) num_waves- is_first_thread_in_wave =- Imp.CmpOpExp (CmpEq int32) in_wave_id 0- wave_not_skipped =- Imp.CmpOpExp (CmpEq int32)- (Imp.BinOpExp (And Int32) wave_id (2 * Imp.var skip_waves int32 - 1))- 0- apply_in_cross_wave_iteration =- Imp.BinOpExp LogAnd arg_in_bounds $- Imp.BinOpExp LogAnd is_first_thread_in_wave wave_not_skipped- cross_wave_reductions =- Imp.SetScalar skip_waves 1 <>- Imp.While doing_cross_wave_reductions- (Imp.Op Imp.Barrier <>- setOffset (Imp.var skip_waves int32 * wave_size) <>- Imp.If apply_in_cross_wave_iteration- cross_wave_reduce mempty <>- Imp.SetScalar skip_waves (Imp.var skip_waves int32 * 2))-- ImpGen.emit $- in_wave_reductions <> cross_wave_reductions-- forM_ (zip dests reduce_acc_params) $ \(dest, reduce_acc_param) ->- ImpGen.copyDWIMDest dest [] (Var $ paramName reduce_acc_param) []- where readReduceArgument offset param arr- | Prim _ <- paramType param =- ImpGen.copyDWIM (paramName param) [] (Var arr) [i]- | otherwise =- return ()- where i = ImpGen.varIndex (kernelLocalThreadId constants) + ImpGen.varIndex offset-- writeReduceOpResult i param arr- | Prim _ <- paramType param =- ImpGen.copyDWIM arr [ImpGen.varIndex i] (Var $ paramName param) []- | otherwise =- return ()--compileKernelExp constants _ (GroupScan w lam input) = do- renamed_lam <- renameLambda lam- w' <- ImpGen.compileSubExp w-- when (any (not . primType . paramType) $ lambdaParams lam) $- compilerLimitationS "Cannot compile parallel scans with array element type."-- let local_tid = kernelLocalThreadId constants- (_nes, arrs) = unzip input- (lam_i, other_index_param, actual_params) =- partitionChunkedKernelLambdaParameters $ lambdaParams lam- (x_params, y_params) =- splitAt (length input) actual_params-- ImpGen.declaringLParams (lambdaParams lam++lambdaParams renamed_lam) $ do- ImpGen.emit $ Imp.SetScalar lam_i $ Imp.var local_tid int32-- acc_local_mem <- flip zip (repeat ()) <$>- mapM (fmap (ImpGen.memLocationName . ImpGen.entryArrayLocation) .- ImpGen.lookupArray) arrs-- -- The scan works by splitting the group into blocks, which are- -- scanned separately. Typically, these blocks are smaller than- -- the lockstep width, which enables barrier-free execution inside- -- them.- --- -- We hardcode the block size here. The only requirement is that- -- it should not be less than the square root of the group size.- -- With 32, we will work on groups of size 1024 or smaller, which- -- fits every device Troels has seen. Still, it would be nicer if- -- it were a runtime parameter. Some day.- let block_size = Imp.ValueExp $ IntValue $ Int32Value 32- simd_width = Imp.sizeToExp $ kernelWaveSize constants- block_id = Imp.var local_tid int32 `quot` block_size- in_block_id = Imp.var local_tid int32 - block_id * block_size- doInBlockScan active = inBlockScan simd_width block_size active local_tid acc_local_mem- lid_in_bounds = Imp.CmpOpExp (CmpSlt Int32) (Imp.var local_tid int32) w'-- doInBlockScan lid_in_bounds lam- ImpGen.emit $ Imp.Op Imp.Barrier-- pack_block_results <-- ImpGen.collect $- zipWithM_ (writeParamToLocalMemory block_id) acc_local_mem y_params-- let last_in_block =- Imp.CmpOpExp (CmpEq int32) in_block_id $ block_size - 1- ImpGen.comment- "last thread of block 'i' writes its result to offset 'i'" $- ImpGen.emit $ Imp.If (Imp.BinOpExp LogAnd last_in_block lid_in_bounds) pack_block_results mempty-- ImpGen.emit $ Imp.Op Imp.Barrier-- let is_first_block = Imp.CmpOpExp (CmpEq int32) block_id 0- ImpGen.comment- "scan the first block, after which offset 'i' contains carry-in for warp 'i+1'" $- doInBlockScan (Imp.BinOpExp LogAnd is_first_block lid_in_bounds) renamed_lam-- ImpGen.emit $ Imp.Op Imp.Barrier-- read_carry_in <-- ImpGen.collect $- zipWithM_ (readParamFromLocalMemory- (paramName other_index_param) (block_id - 1))- x_params acc_local_mem-- y_dest <- ImpGen.destinationFromParams y_params- op_to_y <- ImpGen.collect $ ImpGen.compileBody y_dest $ lambdaBody lam- write_final_result <- ImpGen.collect $- zipWithM_ (writeParamToLocalMemory $ Imp.var local_tid int32) acc_local_mem y_params-- ImpGen.comment "carry-in for every block except the first" $- ImpGen.emit $ Imp.If (Imp.BinOpExp LogOr- is_first_block- (Imp.UnOpExp Not lid_in_bounds)) mempty $- Imp.Comment "read operands" read_carry_in <>- Imp.Comment "perform operation" op_to_y <>- Imp.Comment "write final result" write_final_result-- ImpGen.emit $ Imp.Op Imp.Barrier-- ImpGen.comment "restore correct values for first block" $- ImpGen.emit $ Imp.If is_first_block write_final_result mempty---compileKernelExp constants (ImpGen.Destination _ final_targets) (GroupStream w maxchunk lam accs _arrs) = do- let GroupStreamLambda block_size block_offset acc_params arr_params body = lam- block_offset' = Imp.var block_offset int32- w' <- ImpGen.compileSubExp w- max_block_size <- ImpGen.compileSubExp maxchunk- acc_dest <- ImpGen.destinationFromParams acc_params-- ImpGen.declaringLParams (acc_params++arr_params) $ do- zipWithM_ ImpGen.compileSubExpTo (ImpGen.valueDestinations acc_dest) accs- ImpGen.declaringPrimVar block_size int32 $- -- If the GroupStream is morally just a do-loop, generate simpler code.- case mapM isSimpleThreadInSpace $ stmsToList $ bodyStms body of- Just stms' | ValueExp x <- max_block_size, oneIsh x -> do- let body' = body { bodyStms = stmsFromList stms' }- body'' <- ImpGen.withPrimVar block_offset int32 $- allThreads constants $ ImpGen.emit =<<- ImpGen.compileLoopBody (map paramName acc_params) body'- ImpGen.emit $ Imp.SetScalar block_size 1-- -- Check if loop is candidate for unrolling.- let loop =- case w of- Var w_var | Just w_bound <- lookup w_var $ kernelStreamed constants,- w_bound /= Imp.ConstSize 1 ->- -- Candidate for unrolling, so generate two loops.- Imp.If (CmpOpExp (CmpEq int32) w' (Imp.sizeToExp w_bound))- (Imp.For block_offset Int32 (Imp.sizeToExp w_bound) body'')- (Imp.For block_offset Int32 w' body'')- _ -> Imp.For block_offset Int32 w' body''-- ImpGen.emit $- if kernelThreadActive constants == Imp.ValueExp (BoolValue True)- then loop- else Imp.If (kernelThreadActive constants) loop mempty-- _ -> ImpGen.declaringPrimVar block_offset int32 $ do- body' <- streaming constants block_size maxchunk $- ImpGen.compileBody acc_dest body-- ImpGen.emit $ Imp.SetScalar block_offset 0-- let not_at_end =- Imp.CmpOpExp (CmpSlt Int32) block_offset' w'- set_block_size =- Imp.If (Imp.CmpOpExp (CmpSlt Int32)- (w' - block_offset')- max_block_size)- (Imp.SetScalar block_size (w' - block_offset'))- (Imp.SetScalar block_size max_block_size)- increase_offset =- Imp.SetScalar block_offset $- block_offset' + max_block_size-- -- Three cases to consider for simpler generated code based- -- on max block size: (0) if full input size, do not- -- generate a loop; (1) if one, generate for-loop (2)- -- otherwise, generate chunked while-loop.- ImpGen.emit $- if max_block_size == w' then- Imp.SetScalar block_size w' <> body'- else if max_block_size == Imp.ValueExp (value (1::Int32)) then- Imp.SetScalar block_size w' <>- Imp.For block_offset Int32 w' body'- else- Imp.While not_at_end $- set_block_size <> body' <> increase_offset-- zipWithM_ ImpGen.compileSubExpTo final_targets $- map (Var . paramName) acc_params-- where isSimpleThreadInSpace (Let _ _ Op{}) = Nothing- isSimpleThreadInSpace bnd = Just bnd--compileKernelExp _ _ (GroupGenReduce w [a] op bucket [v] _)- | [Prim t] <- lambdaReturnType op,- primBitSize t == 32 = do- -- If we have only one array and one non-array value (this is a- -- one-to-one correspondance) then we need only one- -- update. If operator has an atomic implementation we use- -- that, otherwise it is still a binary operator which can- -- be implemented by atomic compare-and-swap if 32 bits.-- -- Common variables.- old <- newVName "old"- old_bits <- newVName "old_bits"- ImpGen.emit $ Imp.DeclareScalar old t- ImpGen.emit $ Imp.DeclareScalar old_bits int32- bucket' <- mapM ImpGen.compileSubExp bucket- w' <- mapM ImpGen.compileSubExp w-- (arr', _a_space, bucket_offset) <- ImpGen.fullyIndexArray a bucket'-- case opHasAtomicSupport old arr' bucket_offset op of- Just f -> do- val' <- ImpGen.compileSubExp v-- ImpGen.emit $- Imp.If (indexInBounds bucket' w')- (Imp.Op $ f val')- Imp.Skip-- Nothing -> do- -- Code generation target:- --- -- old = d_his[idx];- -- do {- -- assumed = old;- -- tmp = OP::apply(val, assumed);- -- old = atomicCAS(&d_his[idx], assumed, tmp);- -- } while(assumed != old);- assumed <- newVName "assumed"- run_loop <- newVName "run_loop"- ImpGen.emit $ Imp.DeclareScalar assumed t- ImpGen.emit $ Imp.DeclareScalar run_loop int32-- read_old <- ImpGen.collect $- ImpGen.copyDWIMDest (ImpGen.ScalarDestination old) [] (Var a) bucket'-- ImpGen.emit $- Imp.If (indexInBounds bucket' w')- -- True branch: bucket in-bounds -> enter loop- (Imp.SetScalar run_loop 1 <> read_old)- -- False branch: bucket out-of-bounds -> skip loop- (Imp.SetScalar run_loop 0)-- -- Preparing parameters- let (acc_p:arr_p:_) = lambdaParams op-- -- Store result from operator in accumulators- dests <- ImpGen.destinationFromParams [acc_p]-- -- Critical section- ImpGen.declaringLParams (lambdaParams op) $ do- bind_acc_param <- ImpGen.collect $- ImpGen.copyDWIMDest (ImpGen.ScalarDestination $ paramName acc_p) [] v []-- let bind_arr_param =- Imp.SetScalar (paramName arr_p) $ Imp.var assumed t-- op_body <- ImpGen.collect $- ImpGen.compileBody dests $ lambdaBody op-- -- While-loop: Try to insert your value- let (toBits, fromBits) =- case t of FloatType Float32 -> (\x -> Imp.FunExp "to_bits32" [x] int32,- \x -> Imp.FunExp "from_bits32" [x] t)- _ -> (id, id)- ImpGen.emit $ Imp.While (Imp.var run_loop int32)- (Imp.SetScalar assumed (Imp.var old t) <>- bind_acc_param <> bind_arr_param <> op_body- <>- (Imp.Op $- Imp.Atomic $- Imp.AtomicCmpXchg old_bits arr' bucket_offset- (toBits (Imp.var assumed int32)) (toBits (Imp.var (paramName acc_p) int32)))- <>- Imp.SetScalar old (fromBits (Imp.var old_bits int32))- <>- Imp.If- (Imp.CmpOpExp- (CmpEq int32) (toBits $ Imp.var assumed t) (Imp.var old_bits int32))- -- True branch:- (Imp.SetScalar run_loop 0)- -- False branch:- Imp.Skip- )-- where opHasAtomicSupport old arr' bucket' lam = do- let atomic f = Imp.Atomic . f old arr' bucket'- atomics = [ (Add Int32, Imp.AtomicAdd)- , (SMax Int32, Imp.AtomicSMax)- , (SMin Int32, Imp.AtomicSMin)- , (UMax Int32, Imp.AtomicUMax)- , (UMin Int32, Imp.AtomicUMin)- , (And Int32, Imp.AtomicAnd)- , (Or Int32, Imp.AtomicOr)- , (Xor Int32, Imp.AtomicXor)- ]- [BasicOp (BinOp bop _ _)] <-- Just $ map stmExp $ stmsToList $ bodyStms $ lambdaBody lam- atomic <$> lookup bop atomics--compileKernelExp _ _ (GroupGenReduce w arrs op bucket values locks) = do- old <- newVName "old"- tmp <- newVName "tmp"- loop_done <- newVName "loop_done"- ImpGen.emit $- Imp.DeclareScalar old int32 <>- Imp.DeclareScalar tmp int32 <>- Imp.DeclareScalar loop_done int32-- -- Check if bucket is in-bounds- bucket' <- mapM ImpGen.compileSubExp bucket- w' <- mapM ImpGen.compileSubExp w-- -- Correctly index into locks.- (locks', _locks_space, locks_offset) <-- ImpGen.fullyIndexArray locks bucket'-- ImpGen.emit $- Imp.If (indexInBounds bucket' w')- -- True branch: bucket in-bounds -> enter loop- (Imp.SetScalar loop_done 0)- -- False branch: bucket out-of-bounds -> skip loop- (Imp.SetScalar loop_done 1)-- -- Preparing parameters- let (acc_params, arr_params) =- splitAt (length values) $ lambdaParams op-- -- Store result from operator in accumulators- dests <- ImpGen.destinationFromParams acc_params-- -- Critical section- ImpGen.declaringLParams (lambdaParams op) $ do- let try_acquire_lock =- Imp.Op $ Imp.Atomic $- Imp.AtomicXchg old locks' locks_offset 1- lock_acquired =- Imp.CmpOpExp (CmpEq int32) (Imp.var old int32) 0- loop_cond =- Imp.CmpOpExp (CmpEq int32) (Imp.var loop_done int32) 0- break_loop =- Imp.SetScalar loop_done 1-- -- We copy the current value and the new value to the parameters- -- unless they are array-typed. If they are arrays, then the- -- index functions should already be set up correctly, so there is- -- nothing more to do.- bind_acc_params <- ImpGen.collect $- forM_ (zip acc_params arrs) $ \(acc_p, arr) ->- when (primType (paramType acc_p)) $- ImpGen.copyDWIMDest (ImpGen.ScalarDestination $ paramName acc_p) [] (Var arr) bucket'-- bind_arr_params <- ImpGen.collect $- forM_ (zip arr_params values) $ \(arr_p, val) ->- when (primType (paramType arr_p)) $- ImpGen.copyDWIMDest (ImpGen.ScalarDestination $ paramName arr_p) [] val []-- op_body <- ImpGen.collect $- ImpGen.compileBody dests $ lambdaBody op-- do_gen_reduce <- ImpGen.collect $- zipWithM_ (writeArray bucket') arrs $ map (Var . paramName) acc_params-- release_lock <- ImpGen.collect $- ImpGen.copyDWIM locks bucket' (intConst Int32 0) []-- -- While-loop: Try to insert your value- ImpGen.emit $ Imp.While loop_cond- (try_acquire_lock <>- Imp.If lock_acquired- -- True branch- (bind_acc_params <> bind_arr_params <> op_body <> do_gen_reduce <> release_lock <> break_loop)- -- False branch- Imp.Skip- <>- Imp.Op Imp.MemFence- )- where writeArray i arr val =- ImpGen.copyDWIM arr i val []--compileKernelExp _ dest e =- compilerBugS $ unlines ["Invalid target", " " ++ show dest,- "for kernel expression", " " ++ pretty e]---- Requires that the lists are of equal length, otherwise--- zip with truncate the longer list.-indexInBounds :: [Imp.Exp] -> [Imp.Exp] -> Imp.Exp-indexInBounds inds bounds =- foldl1 (Imp.BinOpExp LogAnd) $ zipWith checkBound inds bounds- where checkBound ind bound =- Imp.BinOpExp LogAnd- (Imp.CmpOpExp (CmpSle Int32) 0 ind)- (Imp.CmpOpExp (CmpSlt Int32) ind bound)--allThreads :: KernelConstants -> InKernelGen () -> InKernelGen Imp.KernelCode-allThreads constants = ImpGen.subImpM_ $ inKernelOperations constants'- where constants' =- constants { kernelThreadActive = Imp.ValueExp (BoolValue True) }--streaming :: KernelConstants -> VName -> SubExp -> InKernelGen () -> InKernelGen Imp.KernelCode-streaming constants chunksize bound m = do- bound' <- ImpGen.subExpToDimSize bound- let constants' =- constants { kernelStreamed = (chunksize, bound') : kernelStreamed constants }- ImpGen.subImpM_ (inKernelOperations constants') m--compileKernelResult :: KernelConstants -> ImpGen.ValueDestination -> KernelResult- -> InKernelGen ()--compileKernelResult constants dest (ThreadsReturn OneResultPerGroup what) = do- i <- newVName "i"-- in_local_memory <- arrayInLocalMemory what- let me = Imp.var (kernelLocalThreadId constants) int32-- if not in_local_memory then do- write_result <-- ImpGen.collect $- ImpGen.copyDWIMDest dest [ImpGen.varIndex $ kernelGroupId constants] what []-- who' <- ImpGen.compileSubExp $ intConst Int32 0- ImpGen.emit $- Imp.If (Imp.CmpOpExp (CmpEq int32) me who') write_result mempty- else do- -- If the result of the group is an array in local memory, we- -- store it by collective copying among all the threads of the- -- group. TODO: also do this if the array is in global memory- -- (but this is a bit more tricky, synchronisation-wise).- --- -- We do the reads/writes multidimensionally, but the loop is- -- single-dimensional.- ws <- mapM ImpGen.compileSubExp . arrayDims =<< subExpType what- -- Compute how many elements this thread is responsible for.- -- Formula: (w - ltid) / group_size (rounded up).- let w = product ws- ltid = ImpGen.varIndex (kernelLocalThreadId constants)- group_size = Imp.sizeToExp (kernelGroupSize constants)- to_write = (w - ltid) `quotRoundingUp` group_size- is = unflattenIndex ws $ ImpGen.varIndex i * group_size + ltid-- write_result <-- ImpGen.collect $- ImpGen.copyDWIMDest dest (ImpGen.varIndex (kernelGroupId constants) : is)- what is-- ImpGen.emit $ Imp.For i Int32 to_write write_result--compileKernelResult constants dest (ThreadsReturn AllThreads what) =- ImpGen.copyDWIMDest dest [ImpGen.varIndex $ kernelGlobalThreadId constants] what []--compileKernelResult constants dest (ThreadsReturn (ThreadsPerGroup limit) what) = do- write_result <-- ImpGen.collect $- ImpGen.copyDWIMDest dest [ImpGen.varIndex $ kernelGroupId constants] what []-- ImpGen.emit $ Imp.If (isActive limit) write_result mempty--compileKernelResult constants dest (ThreadsReturn ThreadsInSpace what) = do- let is = map (ImpGen.varIndex . fst) $ kernelDimensions constants- write_result <- ImpGen.collect $ ImpGen.copyDWIMDest dest is what []- ImpGen.emit $ Imp.If (kernelThreadActive constants)- write_result mempty--compileKernelResult constants dest (ConcatReturns SplitContiguous _ per_thread_elems moffset what) = do- ImpGen.ArrayDestination (Just dest_loc) <- return dest- let dest_loc_offset = ImpGen.offsetArray dest_loc offset- dest' = ImpGen.ArrayDestination $ Just dest_loc_offset- ImpGen.copyDWIMDest dest' [] (Var what) []- where offset = case moffset of- Nothing -> ImpGen.compileSubExpOfType int32 per_thread_elems *- ImpGen.varIndex (kernelGlobalThreadId constants)- Just se -> ImpGen.compileSubExpOfType int32 se--compileKernelResult constants dest (ConcatReturns (SplitStrided stride) _ _ moffset what) = do- ImpGen.ArrayDestination (Just dest_loc) <- return dest- let dest_loc' = ImpGen.strideArray- (ImpGen.offsetArray dest_loc offset) $- ImpGen.compileSubExpOfType int32 stride- dest' = ImpGen.ArrayDestination $ Just dest_loc'- ImpGen.copyDWIMDest dest' [] (Var what) []- where offset = case moffset of- Nothing -> ImpGen.varIndex (kernelGlobalThreadId constants)- Just se -> ImpGen.compileSubExpOfType int32 se--compileKernelResult constants dest (WriteReturn rws _arr dests) = do- rws' <- mapM ImpGen.compileSubExp rws- forM_ dests $ \(is, e) -> do- is' <- mapM ImpGen.compileSubExp is- let condInBounds0 = Imp.CmpOpExp (Imp.CmpSle Int32) $- Imp.ValueExp (IntValue (Int32Value 0))- condInBounds1 = Imp.CmpOpExp (Imp.CmpSlt Int32)- condInBounds i rw = Imp.BinOpExp LogAnd (condInBounds0 i) (condInBounds1 i rw)- write = foldl (Imp.BinOpExp LogAnd) (kernelThreadActive constants) $- zipWith condInBounds is' rws'- actual_body' <- ImpGen.collect $- ImpGen.copyDWIMDest dest (map (ImpGen.compileSubExpOfType int32) is) e []- ImpGen.emit $ Imp.If write actual_body' Imp.Skip--compileKernelResult _ _ KernelInPlaceReturn{} =- -- Already in its place... said it was a hack.- return ()--isActive :: [(VName, SubExp)] -> Imp.Exp-isActive limit = case actives of- [] -> Imp.ValueExp $ BoolValue True- x:xs -> foldl (Imp.BinOpExp LogAnd) x xs- where (is, ws) = unzip limit- actives = zipWith active is $ map (ImpGen.compileSubExpOfType Bool) ws- active i = Imp.CmpOpExp (CmpSlt Int32) (Imp.var i Bool)--setSpaceIndices :: KernelSpace -> InKernelGen ()-setSpaceIndices space =- case spaceStructure space of- FlatThreadSpace is_and_dims ->- flatSpaceWith gtid is_and_dims- NestedThreadSpace is_and_dims -> do- let (gtids, gdims, ltids, ldims) = unzip4 is_and_dims- gdims' <- mapM ImpGen.compileSubExp gdims- ldims' <- mapM ImpGen.compileSubExp ldims- let (gtid_es, ltid_es) = unzip $ unflattenNestedIndex gdims' ldims' gtid- forM_ (zip gtids gtid_es) $ \(i,e) ->- ImpGen.emit $ Imp.SetScalar i e- forM_ (zip ltids ltid_es) $ \(i,e) ->- ImpGen.emit $ Imp.SetScalar i e- where gtid = Imp.var (spaceGlobalId space) int32-- flatSpaceWith base is_and_dims = do- let (is, dims) = unzip is_and_dims- dims' <- mapM ImpGen.compileSubExp dims- let index_expressions = unflattenIndex dims' base- forM_ (zip is index_expressions) $ \(i, x) ->- ImpGen.emit $ Imp.SetScalar i x+import Futhark.CodeGen.ImpGen ((<--),+ sFor, sWhile, sComment, sIf, sWhen, sUnless,+ sOp,+ dPrim, dPrim_, dPrimV)+import Futhark.CodeGen.ImpGen.Kernels.Transpose+import qualified Futhark.Representation.ExplicitMemory.IndexFunction as IxFun+import Futhark.CodeGen.SetDefaultSpace+import Futhark.Tools (partitionChunkedKernelLambdaParameters)+import Futhark.Util.IntegralExp (quotRoundingUp, quot, rem, IntegralExp)+import Futhark.Util (splitAt3)++type CallKernelGen = ImpGen.ImpM ExplicitMemory Imp.HostOp+type InKernelGen = ImpGen.ImpM InKernel Imp.KernelOp++callKernelOperations :: ImpGen.Operations ExplicitMemory Imp.HostOp+callKernelOperations =+ ImpGen.Operations { ImpGen.opsExpCompiler = expCompiler+ , ImpGen.opsCopyCompiler = callKernelCopy+ , ImpGen.opsOpCompiler = opCompiler+ , ImpGen.opsStmsCompiler = ImpGen.defCompileStms+ }++inKernelOperations :: KernelConstants -> ImpGen.Operations InKernel Imp.KernelOp+inKernelOperations constants = (ImpGen.defaultOperations $ compileInKernelOp constants)+ { ImpGen.opsCopyCompiler = inKernelCopy+ , ImpGen.opsExpCompiler = inKernelExpCompiler+ , ImpGen.opsStmsCompiler = \_ -> compileKernelStms constants+ }++compileProg :: MonadFreshNames m => Prog ExplicitMemory -> m (Either InternalError Imp.Program)+compileProg prog =+ fmap (setDefaultSpace (Imp.Space "device")) <$>+ ImpGen.compileProg callKernelOperations (Imp.Space "device") prog++opCompiler :: Pattern ExplicitMemory -> Op ExplicitMemory+ -> CallKernelGen ()+opCompiler dest (Alloc e space) =+ ImpGen.compileAlloc dest e space+opCompiler dest (Inner kernel) =+ kernelCompiler dest kernel++compileInKernelOp :: KernelConstants -> Pattern InKernel -> Op InKernel+ -> InKernelGen ()+compileInKernelOp _ (Pattern _ [mem]) Alloc{} =+ compilerLimitationS $ "Cannot allocate memory block " ++ pretty mem ++ " in kernel."+compileInKernelOp _ dest Alloc{} =+ compilerBugS $ "Invalid target for in-kernel allocation: " ++ show dest+compileInKernelOp constants pat (Inner op) =+ compileKernelExp constants pat op++-- | Recognise kernels (maps), give everything else back.+kernelCompiler :: Pattern ExplicitMemory -> Kernel InKernel+ -> CallKernelGen ()++kernelCompiler (Pattern _ [pe]) (GetSize key size_class) =+ sOp $ Imp.GetSize (patElemName pe) key size_class++kernelCompiler (Pattern _ [pe]) (CmpSizeLe key size_class x) =+ sOp . Imp.CmpSizeLe (patElemName pe) key size_class =<< ImpGen.compileSubExp x++kernelCompiler (Pattern _ [pe]) (GetSizeMax size_class) =+ sOp $ Imp.GetSizeMax (patElemName pe) size_class++kernelCompiler pat (Kernel desc space _ kernel_body) = do++ group_size' <- ImpGen.subExpToDimSize $ spaceGroupSize space+ num_threads' <- ImpGen.subExpToDimSize $ spaceNumThreads space++ let bound_in_kernel =+ M.keys $+ scopeOfKernelSpace space <>+ scopeOf (kernelBodyStms kernel_body)++ let global_tid = spaceGlobalId space+ local_tid = spaceLocalId space+ group_id = spaceGroupId space+ wave_size <- newVName "wave_size"+ inner_group_size <- newVName "group_size"+ thread_active <- newVName "thread_active"++ let (space_is, space_dims) = unzip $ spaceDimensions space+ space_dims' <- mapM ImpGen.compileSubExp space_dims+ let constants = KernelConstants global_tid local_tid group_id+ group_size' num_threads'+ (Imp.VarSize wave_size) (zip space_is space_dims')+ (Imp.var thread_active Bool) mempty++ kernel_body' <-+ makeAllMemoryGlobal $ ImpGen.subImpM_ (inKernelOperations constants) $ do+ dPrim_ wave_size int32+ dPrim_ inner_group_size int32+ dPrim_ thread_active Bool+ ImpGen.dScope Nothing (scopeOfKernelSpace space)++ sOp (Imp.GetGlobalId global_tid 0)+ sOp (Imp.GetLocalId local_tid 0)+ sOp (Imp.GetLocalSize inner_group_size 0)+ sOp (Imp.GetLockstepWidth wave_size)+ sOp (Imp.GetGroupId group_id 0)++ setSpaceIndices space++ thread_active <-- isActive (spaceDimensions space)++ compileKernelBody pat constants kernel_body++ (uses, local_memory) <- computeKernelUses kernel_body' bound_in_kernel++ forM_ (kernelHints desc) $ \(s,v) -> do+ ty <- case v of+ Constant pv -> return $ Prim $ primValueType pv+ Var vn -> lookupType vn+ unless (primType ty) $ fail $ concat [ "debugKernelHint '", s, "'"+ , " in kernel '", kernelName desc, "'"+ , " did not have primType value." ]++ ImpGen.compileSubExp v >>= ImpGen.emit . Imp.DebugPrint s (elemType ty)++ sOp $ Imp.CallKernel $ Imp.AnyKernel Imp.Kernel+ { Imp.kernelBody = kernel_body'+ , Imp.kernelLocalMemory = local_memory+ , Imp.kernelUses = uses+ , Imp.kernelNumGroups = [ImpGen.compileSubExpOfType int32 $ spaceNumGroups space]+ , Imp.kernelGroupSize = [ImpGen.compileSubExpOfType int32 $ spaceGroupSize space]+ , Imp.kernelName = nameFromString $ kernelName desc ++ "_" +++ show (baseTag global_tid)+ }++kernelCompiler pat e =+ compilerBugS $ "ImpGen.kernelCompiler: Invalid pattern\n " +++ pretty pat ++ "\nfor expression\n " ++ pretty e++expCompiler :: ImpGen.ExpCompiler ExplicitMemory Imp.HostOp+-- We generate a simple kernel for itoa and replicate.+expCompiler (Pattern _ [pe]) (BasicOp (Iota n x s et)) = do+ destloc <- ImpGen.entryArrayLocation <$> ImpGen.lookupArray (patElemName pe)+ let tag = Just $ baseTag $ patElemName pe+ thread_gid <- maybe (newVName "thread_gid") (return . VName (nameFromString "thread_gid")) tag++ makeAllMemoryGlobal $ do+ (destmem, destspace, destidx) <-+ ImpGen.fullyIndexArray' destloc [ImpGen.varIndex thread_gid] (IntType et)++ n' <- ImpGen.compileSubExp n+ x' <- ImpGen.compileSubExp x+ s' <- ImpGen.compileSubExp s++ let body = Imp.Write destmem destidx (IntType et) destspace Imp.Nonvolatile $+ Imp.ConvOpExp (SExt Int32 et) (Imp.var thread_gid int32) * s' + x'++ (group_size, num_groups) <- computeMapKernelGroups n'++ (body_uses, _) <- computeKernelUses+ (freeIn body <> freeIn [n',x',s'])+ [thread_gid]++ sOp $ Imp.CallKernel $ Imp.Map Imp.MapKernel+ { Imp.mapKernelThreadNum = thread_gid+ , Imp.mapKernelDesc = "iota"+ , Imp.mapKernelNumGroups = Imp.VarSize num_groups+ , Imp.mapKernelGroupSize = Imp.VarSize group_size+ , Imp.mapKernelSize = n'+ , Imp.mapKernelUses = body_uses+ , Imp.mapKernelBody = body+ }++expCompiler+ (Pattern _ [pe]) (BasicOp (Replicate (Shape ds) se)) = do+ constants <- simpleKernelConstants (Just $ baseTag $ patElemName pe) "replicate"++ t <- subExpType se+ let thread_gid = kernelGlobalThreadId constants+ row_dims = arrayDims t+ dims = ds ++ row_dims+ is' = unflattenIndex (map (ImpGen.compileSubExpOfType int32) dims) $+ ImpGen.varIndex thread_gid+ ds' <- mapM ImpGen.compileSubExp ds++ makeAllMemoryGlobal $ do+ body <- ImpGen.subImpM_ (inKernelOperations constants) $+ ImpGen.copyDWIM (patElemName pe) is' se $ drop (length ds) is'++ dims' <- mapM ImpGen.compileSubExp dims+ (group_size, num_groups) <- computeMapKernelGroups $ product dims'++ (body_uses, _) <- computeKernelUses+ (freeIn body <> freeIn ds')+ [thread_gid]++ sOp $ Imp.CallKernel $ Imp.Map Imp.MapKernel+ { Imp.mapKernelThreadNum = thread_gid+ , Imp.mapKernelDesc = "replicate"+ , Imp.mapKernelNumGroups = Imp.VarSize num_groups+ , Imp.mapKernelGroupSize = Imp.VarSize group_size+ , Imp.mapKernelSize = product dims'+ , Imp.mapKernelUses = body_uses+ , Imp.mapKernelBody = body+ }++-- Allocation in the "local" space is just a placeholder.+expCompiler _ (Op (Alloc _ (Space "local"))) =+ return ()++expCompiler dest e =+ ImpGen.defCompileExp dest e++callKernelCopy :: ImpGen.CopyCompiler ExplicitMemory Imp.HostOp+callKernelCopy bt+ destloc@(ImpGen.MemLocation destmem destshape destIxFun)+ srcloc@(ImpGen.MemLocation srcmem srcshape srcIxFun)+ n+ | Just (destoffset, srcoffset,+ num_arrays, size_x, size_y,+ src_elems, dest_elems) <- isMapTransposeKernel bt destloc srcloc = do++ fname <- mapTransposeForType bt+ ImpGen.emit $ Imp.Call [] fname+ [Imp.MemArg destmem, Imp.ExpArg destoffset,+ Imp.MemArg srcmem, Imp.ExpArg srcoffset,+ Imp.ExpArg num_arrays, Imp.ExpArg size_x, Imp.ExpArg size_y,+ Imp.ExpArg src_elems, Imp.ExpArg dest_elems]++ | bt_size <- primByteSize bt,+ ixFunMatchesInnerShape+ (Shape $ map Imp.sizeToExp destshape) destIxFun,+ ixFunMatchesInnerShape+ (Shape $ map Imp.sizeToExp srcshape) srcIxFun,+ Just destoffset <-+ IxFun.linearWithOffset destIxFun bt_size,+ Just srcoffset <-+ IxFun.linearWithOffset srcIxFun bt_size = do+ let row_size = product $ map ImpGen.dimSizeToExp $ drop 1 srcshape+ srcspace <- ImpGen.entryMemSpace <$> ImpGen.lookupMemory srcmem+ destspace <- ImpGen.entryMemSpace <$> ImpGen.lookupMemory destmem+ ImpGen.emit $ Imp.Copy+ destmem (bytes destoffset) destspace+ srcmem (bytes srcoffset) srcspace $+ (n * row_size) `Imp.withElemType` bt++ | otherwise = do+ global_thread_index <- newVName "copy_global_thread_index"++ -- Note that the shape of the destination and the source are+ -- necessarily the same.+ let shape = map Imp.sizeToExp srcshape+ shape_se = map (Imp.innerExp . ImpGen.dimSizeToExp) srcshape+ dest_is = unflattenIndex shape_se $ ImpGen.varIndex global_thread_index+ src_is = dest_is++ makeAllMemoryGlobal $ do+ (_, destspace, destidx) <- ImpGen.fullyIndexArray' destloc dest_is bt+ (_, srcspace, srcidx) <- ImpGen.fullyIndexArray' srcloc src_is bt++ let body = Imp.Write destmem destidx bt destspace Imp.Nonvolatile $+ Imp.index srcmem srcidx bt srcspace Imp.Nonvolatile++ let writes_to = [Imp.MemoryUse destmem]++ reads_from <- readsFromSet $+ S.singleton srcmem <>+ freeIn destIxFun <> freeIn srcIxFun <> freeIn destshape++ let kernel_size = Imp.innerExp n * product (drop 1 shape)+ (group_size, num_groups) <- computeMapKernelGroups kernel_size++ let bound_in_kernel = [global_thread_index]+ (body_uses, _) <- computeKernelUses (kernel_size, body) bound_in_kernel++ sOp $ Imp.CallKernel $ Imp.Map Imp.MapKernel+ { Imp.mapKernelThreadNum = global_thread_index+ , Imp.mapKernelDesc = "copy"+ , Imp.mapKernelNumGroups = Imp.VarSize num_groups+ , Imp.mapKernelGroupSize = Imp.VarSize group_size+ , Imp.mapKernelSize = kernel_size+ , Imp.mapKernelUses = nub $ body_uses ++ writes_to ++ reads_from+ , Imp.mapKernelBody = body+ }++-- | We have no bulk copy operation (e.g. memmove) inside kernels, so+-- turn any copy into a loop.+inKernelCopy :: ImpGen.CopyCompiler InKernel Imp.KernelOp+inKernelCopy = ImpGen.copyElementWise++mapTransposeForType :: PrimType -> ImpGen.ImpM ExplicitMemory Imp.HostOp Name+mapTransposeForType bt = do+ -- XXX: The leading underscore is to avoid clashes with a+ -- programmer-defined function of the same name (this is a bad+ -- solution...).+ let fname = nameFromString $ "_" <> mapTransposeName bt++ exists <- ImpGen.hasFunction fname+ unless exists $ ImpGen.emitFunction fname $ mapTransposeFunction bt++ return fname++mapTransposeName :: PrimType -> String+mapTransposeName bt = "map_transpose_" ++ pretty bt++mapTransposeFunction :: PrimType -> Imp.Function+mapTransposeFunction bt =+ Imp.Function False [] params transpose_code [] []++ where params = [memparam destmem, intparam destoffset,+ memparam srcmem, intparam srcoffset,+ intparam num_arrays, intparam x, intparam y,+ intparam in_elems, intparam out_elems]++ space = Space "device"+ memparam v = Imp.MemParam v space+ intparam v = Imp.ScalarParam v $ IntType Int32++ [destmem, destoffset, srcmem, srcoffset,+ num_arrays, x, y, in_elems, out_elems,+ mulx, muly, block] =+ zipWith (VName . nameFromString)+ ["destmem",+ "destoffset",+ "srcmem",+ "srcoffset",+ "num_arrays",+ "x_elems",+ "y_elems",+ "in_elems",+ "out_elems",+ -- The following is only used for low width/height+ -- transpose kernels+ "mulx",+ "muly",+ "block"+ ]+ [0..]++ v32 v = Imp.var v int32++ block_dim_int = 16++ block_dim :: IntegralExp a => a+ block_dim = 16++ -- When an input array has either width==1 or height==1, performing a+ -- transpose will be the same as performing a copy. If 'input_size' or+ -- 'output_size' is not equal to width*height, then this trick will not+ -- work when there are more than one array to process, as it is a per+ -- array limit. We could copy each array individually, but currently we+ -- do not.+ can_use_copy =+ let in_out_eq = CmpOpExp (CmpEq $ IntType Int32) (v32 in_elems) (v32 out_elems)+ onearr = CmpOpExp (CmpEq $ IntType Int32) (v32 num_arrays) 1+ noprob_widthheight = CmpOpExp (CmpEq $ IntType Int32)+ (v32 x * v32 y)+ (v32 in_elems)+ height_is_one = CmpOpExp (CmpEq $ IntType Int32) (v32 y) 1+ width_is_one = CmpOpExp (CmpEq $ IntType Int32) (v32 x) 1+ in BinOpExp LogAnd+ in_out_eq+ (BinOpExp LogAnd+ (BinOpExp LogOr onearr noprob_widthheight)+ (BinOpExp LogOr width_is_one height_is_one))++ transpose_code =+ Imp.If input_is_empty mempty $ mconcat+ [ Imp.DeclareScalar muly (IntType Int32)+ , Imp.SetScalar muly $ block_dim `quot` v32 x+ , Imp.DeclareScalar mulx (IntType Int32)+ , Imp.SetScalar mulx $ block_dim `quot` v32 y+ , Imp.If can_use_copy copy_code $+ Imp.If should_use_lowwidth (callTransposeKernel TransposeLowWidth) $+ Imp.If should_use_lowheight (callTransposeKernel TransposeLowHeight) $+ Imp.If should_use_small (callTransposeKernel TransposeSmall) $+ callTransposeKernel TransposeNormal]++ input_is_empty =+ v32 num_arrays .==. 0 .||. v32 x .==. 0 .||. v32 y .==. 0++ should_use_small = BinOpExp LogAnd+ (CmpOpExp (CmpSle Int32) (v32 x) (block_dim `quot` 2))+ (CmpOpExp (CmpSle Int32) (v32 y) (block_dim `quot` 2))++ should_use_lowwidth = BinOpExp LogAnd+ (CmpOpExp (CmpSle Int32) (v32 x) (block_dim `quot` 2))+ (CmpOpExp (CmpSlt Int32) block_dim (v32 y))++ should_use_lowheight = BinOpExp LogAnd+ (CmpOpExp (CmpSle Int32) (v32 y) (block_dim `quot` 2))+ (CmpOpExp (CmpSlt Int32) block_dim (v32 x))++ copy_code =+ let num_bytes =+ v32 in_elems * Imp.LeafExp (Imp.SizeOf bt) (IntType Int32)+ in Imp.Copy+ destmem (Imp.Count $ v32 destoffset) space+ srcmem (Imp.Count $ v32 srcoffset) space+ (Imp.Count num_bytes)++ callTransposeKernel =+ Imp.Op . Imp.CallKernel . Imp.AnyKernel .+ mapTransposeKernel (mapTransposeName bt) block_dim_int+ (destmem, v32 destoffset, srcmem, v32 srcoffset,+ v32 x, v32 y, v32 in_elems, v32 out_elems,+ v32 mulx, v32 muly, v32 num_arrays,+ block) bt+++inKernelExpCompiler :: ImpGen.ExpCompiler InKernel Imp.KernelOp+inKernelExpCompiler _ (BasicOp (Assert _ _ (loc, locs))) =+ compilerLimitationS $+ unlines [ "Cannot compile assertion at " +++ intercalate " -> " (reverse $ map locStr $ loc:locs) +++ " inside parallel kernel."+ , "As a workaround, surround the expression with 'unsafe'."]+-- The static arrays stuff does not work inside kernels.+inKernelExpCompiler (Pattern _ [dest]) (BasicOp (ArrayLit es _)) =+ forM_ (zip [0..] es) $ \(i,e) ->+ ImpGen.copyDWIM (patElemName dest) [fromIntegral (i::Int32)] e []+inKernelExpCompiler dest e =+ ImpGen.defCompileExp dest e++computeKernelUses :: FreeIn a =>+ a -> [VName]+ -> CallKernelGen ([Imp.KernelUse], [Imp.LocalMemoryUse])+computeKernelUses kernel_body bound_in_kernel = do+ let actually_free = freeIn kernel_body `S.difference` S.fromList bound_in_kernel++ -- Compute the variables that we need to pass to the kernel.+ reads_from <- readsFromSet actually_free++ -- Are we using any local memory?+ local_memory <- computeLocalMemoryUse actually_free+ return (nub reads_from, nub local_memory)++readsFromSet :: Names -> CallKernelGen [Imp.KernelUse]+readsFromSet free =+ fmap catMaybes $+ forM (S.toList free) $ \var -> do+ t <- lookupType var+ case t of+ Array {} -> return Nothing+ Mem _ (Space "local") -> return Nothing+ Mem _ _ -> return $ Just $ Imp.MemoryUse var+ Prim bt ->+ isConstExp var >>= \case+ Just ce -> return $ Just $ Imp.ConstUse var ce+ Nothing | bt == Cert -> return Nothing+ | otherwise -> return $ Just $ Imp.ScalarUse var bt++computeLocalMemoryUse :: Names -> CallKernelGen [Imp.LocalMemoryUse]+computeLocalMemoryUse free =+ fmap catMaybes $+ forM (S.toList free) $ \var -> do+ t <- lookupType var+ case t of+ Mem memsize (Space "local") -> do+ memsize' <- localMemSize =<< ImpGen.subExpToDimSize memsize+ return $ Just (var, memsize')+ _ -> return Nothing++localMemSize :: Imp.MemSize -> CallKernelGen (Either Imp.MemSize Imp.KernelConstExp)+localMemSize (Imp.ConstSize x) =+ return $ Right $ ValueExp $ IntValue $ Int64Value x+localMemSize (Imp.VarSize v) = isConstExp v >>= \case+ Just e | isStaticExp e -> return $ Right e+ _ -> return $ Left $ Imp.VarSize v++-- | Only some constant expressions quality as *static* expressions,+-- which we can use for static memory allocation. This is a bit of a+-- hack, as it is primarly motivated by what you can put as the size+-- when daring an array in C.+isStaticExp :: Imp.KernelConstExp -> Bool+isStaticExp LeafExp{} = True+isStaticExp ValueExp{} = True+isStaticExp (BinOpExp Add{} x y) = isStaticExp x && isStaticExp y+isStaticExp (BinOpExp Sub{} x y) = isStaticExp x && isStaticExp y+isStaticExp (BinOpExp Mul{} x y) = isStaticExp x && isStaticExp y+isStaticExp _ = False++isConstExp :: VName -> CallKernelGen (Maybe Imp.KernelConstExp)+isConstExp v = do+ vtable <- ImpGen.getVTable+ let lookupConstExp name = constExp =<< hasExp =<< M.lookup name vtable+ constExp (Op (Inner (GetSize key _))) = Just $ LeafExp (Imp.SizeConst key) int32+ constExp e = primExpFromExp lookupConstExp e+ return $ lookupConstExp v+ where hasExp (ImpGen.ArrayVar e _) = e+ hasExp (ImpGen.ScalarVar e _) = e+ hasExp (ImpGen.MemVar e _) = e++-- | Change every memory block to be in the global address space,+-- except those who are in the local memory space. This only affects+-- generated code - we still need to make sure that the memory is+-- actually present on the device (and dared as variables in the+-- kernel).+makeAllMemoryGlobal :: CallKernelGen a -> CallKernelGen a+makeAllMemoryGlobal =+ local (\env -> env { ImpGen.envDefaultSpace = Imp.Space "global" }) .+ ImpGen.localVTable (M.map globalMemory)+ where globalMemory (ImpGen.MemVar _ entry)+ | ImpGen.entryMemSpace entry /= Space "local" =+ ImpGen.MemVar Nothing entry { ImpGen.entryMemSpace = Imp.Space "global" }+ globalMemory entry =+ entry++computeMapKernelGroups :: Imp.Exp -> CallKernelGen (VName, VName)+computeMapKernelGroups kernel_size = do+ group_size <- dPrim "group_size" int32+ let group_size_var = Imp.var group_size int32+ sOp $ Imp.GetSize group_size group_size Imp.SizeGroup+ num_groups <- dPrimV "num_groups" $ kernel_size `quotRoundingUp` Imp.ConvOpExp (SExt Int32 Int32) group_size_var+ return (group_size, num_groups)++isMapTransposeKernel :: PrimType -> ImpGen.MemLocation -> ImpGen.MemLocation+ -> Maybe (Imp.Exp, Imp.Exp,+ Imp.Exp, Imp.Exp, Imp.Exp,+ Imp.Exp, Imp.Exp)+isMapTransposeKernel bt+ (ImpGen.MemLocation _ _ destIxFun)+ (ImpGen.MemLocation _ _ srcIxFun)+ | Just (dest_offset, perm_and_destshape) <- IxFun.rearrangeWithOffset destIxFun bt_size,+ (perm, destshape) <- unzip perm_and_destshape,+ srcshape' <- IxFun.shape srcIxFun,+ Just src_offset <- IxFun.linearWithOffset srcIxFun bt_size,+ Just (r1, r2, _) <- isMapTranspose perm =+ isOk (product srcshape') (product destshape) destshape swap r1 r2 dest_offset src_offset+ | Just dest_offset <- IxFun.linearWithOffset destIxFun bt_size,+ Just (src_offset, perm_and_srcshape) <- IxFun.rearrangeWithOffset srcIxFun bt_size,+ (perm, srcshape) <- unzip perm_and_srcshape,+ destshape' <- IxFun.shape destIxFun,+ Just (r1, r2, _) <- isMapTranspose perm =+ isOk (product srcshape) (product destshape') srcshape id r1 r2 dest_offset src_offset+ | otherwise =+ Nothing+ where bt_size = primByteSize bt+ swap (x,y) = (y,x)++ isOk src_elems dest_elems shape f r1 r2 dest_offset src_offset = do+ let (num_arrays, size_x, size_y) = getSizes shape f r1 r2+ return (dest_offset, src_offset,+ num_arrays, size_x, size_y,+ src_elems, dest_elems)++ getSizes shape f r1 r2 =+ let (mapped, notmapped) = splitAt r1 shape+ (pretrans, posttrans) = f $ splitAt r2 notmapped+ in (product mapped, product pretrans, product posttrans)++writeParamToLocalMemory :: Typed (MemBound u) =>+ Imp.Exp -> (VName, t) -> Param (MemBound u)+ -> ImpGen.ImpM lore op ()+writeParamToLocalMemory i (mem, _) param+ | Prim t <- paramType param =+ ImpGen.emit $+ Imp.Write mem (bytes i') bt (Space "local") Imp.Volatile $+ Imp.var (paramName param) t+ | otherwise =+ return ()+ where i' = i * Imp.LeafExp (Imp.SizeOf bt) int32+ bt = elemType $ paramType param++readParamFromLocalMemory :: Typed (MemBound u) =>+ VName -> Imp.Exp -> Param (MemBound u) -> (VName, t)+ -> ImpGen.ImpM lore op ()+readParamFromLocalMemory index i param (l_mem, _)+ | Prim _ <- paramType param =+ paramName param <--+ Imp.index l_mem (bytes i') bt (Space "local") Imp.Volatile+ | otherwise = index <-- i+ where i' = i * Imp.LeafExp (Imp.SizeOf bt) int32+ bt = elemType $ paramType param++computeThreadChunkSize :: SplitOrdering+ -> Imp.Exp+ -> Imp.Count Imp.Elements+ -> Imp.Count Imp.Elements+ -> VName+ -> ImpGen.ImpM lore op ()+computeThreadChunkSize (SplitStrided stride) thread_index elements_per_thread num_elements chunk_var = do+ stride' <- ImpGen.compileSubExp stride+ chunk_var <--+ Imp.BinOpExp (SMin Int32)+ (Imp.innerExp elements_per_thread)+ ((Imp.innerExp num_elements - thread_index) `quotRoundingUp` stride')++computeThreadChunkSize SplitContiguous thread_index elements_per_thread num_elements chunk_var = do+ starting_point <- dPrimV "starting_point" $+ thread_index * Imp.innerExp elements_per_thread+ remaining_elements <- dPrimV "remaining_elements" $+ Imp.innerExp num_elements - Imp.var starting_point int32++ let no_remaining_elements = Imp.var remaining_elements int32 .<=. 0+ beyond_bounds = Imp.innerExp num_elements .<=. Imp.var starting_point int32++ sIf (no_remaining_elements .||. beyond_bounds)+ (chunk_var <-- 0)+ (sIf is_last_thread+ (chunk_var <-- Imp.innerExp last_thread_elements)+ (chunk_var <-- Imp.innerExp elements_per_thread))+ where last_thread_elements =+ num_elements - Imp.elements thread_index * elements_per_thread+ is_last_thread =+ Imp.innerExp num_elements .<.+ (thread_index + 1) * Imp.innerExp elements_per_thread++inBlockScan :: Imp.Exp+ -> Imp.Exp+ -> Imp.Exp+ -> VName+ -> [(VName, t)]+ -> Lambda InKernel+ -> InKernelGen ()+inBlockScan lockstep_width block_size active local_id acc_local_mem scan_lam = ImpGen.everythingVolatile $ do+ skip_threads <- dPrim "skip_threads" int32+ let in_block_thread_active =+ Imp.var skip_threads int32 .<=. in_block_id+ (scan_lam_i, other_index_param, actual_params) =+ partitionChunkedKernelLambdaParameters $ lambdaParams scan_lam+ (x_params, y_params) =+ splitAt (length actual_params `div` 2) actual_params+ read_operands =+ zipWithM_ (readParamFromLocalMemory (paramName other_index_param) $+ Imp.var local_id int32 - Imp.var skip_threads int32)+ x_params acc_local_mem++ -- Set initial y values+ sWhen active $+ zipWithM_ (readParamFromLocalMemory scan_lam_i $ Imp.var local_id int32)+ y_params acc_local_mem++ let op_to_y = ImpGen.compileBody' y_params $ lambdaBody scan_lam+ write_operation_result =+ zipWithM_ (writeParamToLocalMemory $ Imp.var local_id int32)+ acc_local_mem y_params+ maybeBarrier = sWhen (lockstep_width .<=. Imp.var skip_threads int32) $+ sOp Imp.Barrier++ sComment "in-block scan (hopefully no barriers needed)" $ do+ skip_threads <-- 1+ sWhile (Imp.var skip_threads int32 .<. block_size) $ do+ sWhen (in_block_thread_active .&&. active) $ do+ sComment "read operands" read_operands+ sComment "perform operation" op_to_y++ maybeBarrier++ sWhen (in_block_thread_active .&&. active) $+ sComment "write result" write_operation_result++ maybeBarrier++ skip_threads <-- Imp.var skip_threads int32 * 2++ where block_id = Imp.var local_id int32 `quot` block_size+ in_block_id = Imp.var local_id int32 - block_id * block_size++data KernelConstants = KernelConstants+ { kernelGlobalThreadId :: VName+ , kernelLocalThreadId :: VName+ , kernelGroupId :: VName+ , kernelGroupSize :: Imp.DimSize+ , _kernelNumThreads :: Imp.DimSize+ , kernelWaveSize :: Imp.DimSize+ , kernelDimensions :: [(VName, Imp.Exp)]+ , kernelThreadActive :: Imp.Exp+ , kernelStreamed :: [(VName, Imp.DimSize)]+ -- ^ Chunk sizez and their maximum size. Hint+ -- for unrolling.+ }++-- FIXME: wing a KernelConstants structure for use in Replicate+-- compilation. This cannot be the best way to do this...+simpleKernelConstants :: MonadFreshNames m =>+ Maybe Int -> String+ -> m KernelConstants+simpleKernelConstants tag desc = do+ thread_gtid <- maybe (newVName $ desc ++ "_gtid")+ (return . VName (nameFromString $ desc ++ "_gtid")) tag+ thread_ltid <- newVName $ desc ++ "_ltid"+ thread_gid <- newVName $ desc ++ "_gid"+ return $ KernelConstants+ thread_gtid thread_ltid thread_gid+ (Imp.ConstSize 0) (Imp.ConstSize 0) (Imp.ConstSize 0)+ [] (Imp.ValueExp $ BoolValue True) mempty++compileKernelBody :: Pattern InKernel+ -> KernelConstants+ -> KernelBody InKernel+ -> InKernelGen ()+compileKernelBody pat constants kbody =+ compileKernelStms constants (stmsToList $ kernelBodyStms kbody) $+ zipWithM_ (compileKernelResult constants) (patternElements pat) $+ kernelBodyResult kbody++compileKernelStms :: KernelConstants -> [Stm InKernel]+ -> InKernelGen a+ -> InKernelGen a+compileKernelStms constants ungrouped_bnds m =+ compileGroupedKernelStms' $ groupStmsByGuard constants ungrouped_bnds+ where compileGroupedKernelStms' [] = m+ compileGroupedKernelStms' ((g, bnds):rest_bnds) = do+ ImpGen.dScopes (map ((Just . stmExp) &&& (castScope . scopeOf)) bnds)+ protect g $ mapM_ compileKernelStm bnds+ compileGroupedKernelStms' rest_bnds++ protect Nothing body_m =+ body_m+ protect (Just (Imp.ValueExp (BoolValue True))) body_m =+ body_m+ protect (Just g) body_m =+ sWhen g $ allThreads constants body_m++ compileKernelStm (Let pat _ e) = ImpGen.compileExp pat e++groupStmsByGuard :: KernelConstants+ -> [Stm InKernel]+ -> [(Maybe Imp.Exp, [Stm InKernel])]+groupStmsByGuard constants bnds =+ map collapse $ groupBy sameGuard $ zip (map bindingGuard bnds) bnds+ where bindingGuard (Let _ _ Op{}) = Nothing+ bindingGuard _ = Just $ kernelThreadActive constants++ sameGuard (g1, _) (g2, _) = g1 == g2++ collapse [] =+ (Nothing, [])+ collapse l@((g,_):_) =+ (g, map snd l)++compileKernelExp :: KernelConstants -> Pattern InKernel -> KernelExp InKernel+ -> InKernelGen ()++compileKernelExp _ pat (Barrier ses) = do+ forM_ (zip (patternNames pat) ses) $ \(d, se) ->+ ImpGen.copyDWIM d [] se []+ sOp Imp.Barrier++compileKernelExp _ (Pattern [] [size]) (SplitSpace o w i elems_per_thread) = do+ num_elements <- Imp.elements <$> ImpGen.compileSubExp w+ i' <- ImpGen.compileSubExp i+ elems_per_thread' <- Imp.elements <$> ImpGen.compileSubExp elems_per_thread+ computeThreadChunkSize o i' elems_per_thread' num_elements (patElemName size)++compileKernelExp constants pat (Combine (CombineSpace scatter cspace) _ aspace body) = do+ -- First we compute how many times we have to iterate to cover+ -- cspace with our group size. It is a fairly common case that+ -- we statically know that this requires 1 iteration, so we+ -- could detect it and not generate a loop in that case.+ -- However, it seems to have no impact on performance (an extra+ -- conditional jump), so for simplicity we just always generate+ -- the loop.+ let cspace_dims = map (streamBounded . snd) cspace+ num_iters+ | cspace_dims == [Imp.sizeToExp $ kernelGroupSize constants] = 1+ | otherwise = product cspace_dims `quotRoundingUp`+ Imp.sizeToExp (kernelGroupSize constants)++ iter <- newVName "comb_iter"++ sFor iter Int32 num_iters $ do+ mapM_ ((`dPrim_` int32) . fst) cspace+ -- Compute the *flat* array index.+ cid <- dPrimV "flat_comb_id" $+ Imp.var iter int32 * Imp.sizeToExp (kernelGroupSize constants) ++ Imp.var (kernelLocalThreadId constants) int32++ -- Turn it into a nested array index.+ zipWithM_ (<--) (map fst cspace) $ unflattenIndex cspace_dims (Imp.var cid int32)++ -- Construct the body. This is mostly about the book-keeping+ -- for the scatter-like part.+ let (scatter_ws, scatter_ns, _scatter_vs) = unzip3 scatter+ scatter_ws_repl = concat $ zipWith replicate scatter_ns scatter_ws+ (scatter_pes, normal_pes) =+ splitAt (sum scatter_ns) $ patternElements pat+ (res_is, res_vs, res_normal) =+ splitAt3 (sum scatter_ns) (sum scatter_ns) $ bodyResult body++ -- Execute the body if we are within bounds.+ sWhen (isActive cspace .&&. isActive aspace) $ allThreads constants $+ ImpGen.compileStms (freeIn $ bodyResult body) (stmsToList $ bodyStms body) $ do++ forM_ (zip4 scatter_ws_repl res_is res_vs scatter_pes) $+ \(w, res_i, res_v, scatter_pe) -> do+ let res_i' = ImpGen.compileSubExpOfType int32 res_i+ w' = ImpGen.compileSubExpOfType int32 w+ -- We have to check that 'res_i' is in-bounds wrt. an array of size 'w'.+ in_bounds = 0 .<=. res_i' .&&. res_i' .<. w'+ sWhen in_bounds $ ImpGen.copyDWIM (patElemName scatter_pe) [res_i'] res_v []++ forM_ (zip normal_pes res_normal) $ \(pe, res) ->+ ImpGen.copyDWIM (patElemName pe) local_index res []++ sOp Imp.Barrier++ where streamBounded (Var v)+ | Just x <- lookup v $ kernelStreamed constants =+ Imp.sizeToExp x+ streamBounded se = ImpGen.compileSubExpOfType int32 se++ local_index = map (ImpGen.compileSubExpOfType int32 . Var . fst) cspace++compileKernelExp constants (Pattern _ dests) (GroupReduce w lam input) = do+ groupReduce constants w lam $ map snd input+ let (reduce_acc_params, _) =+ splitAt (length input) $ drop 2 $ lambdaParams lam+ forM_ (zip dests reduce_acc_params) $ \(dest, reduce_acc_param) ->+ ImpGen.copyDWIM (patElemName dest) [] (Var $ paramName reduce_acc_param) []++compileKernelExp constants _ (GroupScan w lam input) = do+ renamed_lam <- renameLambda lam+ w' <- ImpGen.compileSubExp w++ when (any (not . primType . paramType) $ lambdaParams lam) $+ compilerLimitationS "Cannot compile parallel scans with array element type."++ let local_tid = kernelLocalThreadId constants+ (_nes, arrs) = unzip input+ (lam_i, other_index_param, actual_params) =+ partitionChunkedKernelLambdaParameters $ lambdaParams lam+ (x_params, y_params) =+ splitAt (length input) actual_params++ ImpGen.dLParams (lambdaParams lam++lambdaParams renamed_lam)+ lam_i <-- Imp.var local_tid int32++ acc_local_mem <- flip zip (repeat ()) <$>+ mapM (fmap (ImpGen.memLocationName . ImpGen.entryArrayLocation) .+ ImpGen.lookupArray) arrs++ -- The scan works by splitting the group into blocks, which are+ -- scanned separately. Typically, these blocks are smaller than+ -- the lockstep width, which enables barrier-free execution inside+ -- them.+ --+ -- We hardcode the block size here. The only requirement is that+ -- it should not be less than the square root of the group size.+ -- With 32, we will work on groups of size 1024 or smaller, which+ -- fits every device Troels has seen. Still, it would be nicer if+ -- it were a runtime parameter. Some day.+ let block_size = Imp.ValueExp $ IntValue $ Int32Value 32+ simd_width = Imp.sizeToExp $ kernelWaveSize constants+ block_id = Imp.var local_tid int32 `quot` block_size+ in_block_id = Imp.var local_tid int32 - block_id * block_size+ doInBlockScan active = inBlockScan simd_width block_size active local_tid acc_local_mem+ lid_in_bounds = Imp.var local_tid int32 .<. w'++ doInBlockScan lid_in_bounds lam+ sOp Imp.Barrier++ let last_in_block = in_block_id .==. block_size - 1+ sComment "last thread of block 'i' writes its result to offset 'i'" $+ sWhen (last_in_block .&&. lid_in_bounds) $+ zipWithM_ (writeParamToLocalMemory block_id) acc_local_mem y_params++ sOp Imp.Barrier++ let is_first_block = block_id .==. 0+ ImpGen.comment+ "scan the first block, after which offset 'i' contains carry-in for warp 'i+1'" $+ doInBlockScan (is_first_block .&&. lid_in_bounds) renamed_lam++ sOp Imp.Barrier++ let read_carry_in =+ zipWithM_ (readParamFromLocalMemory+ (paramName other_index_param) (block_id - 1))+ x_params acc_local_mem++ let op_to_y =+ ImpGen.compileBody' y_params $ lambdaBody lam+ write_final_result =+ zipWithM_ (writeParamToLocalMemory $ Imp.var local_tid int32) acc_local_mem y_params++ sComment "carry-in for every block except the first" $+ sUnless (is_first_block .||. Imp.UnOpExp Not lid_in_bounds) $ do+ sComment "read operands" read_carry_in+ sComment "perform operation" op_to_y+ sComment "write final result" write_final_result++ sOp Imp.Barrier++ sComment "restore correct values for first block" $+ sWhen is_first_block write_final_result++compileKernelExp constants (Pattern _ final) (GroupStream w maxchunk lam accs _arrs) = do+ let GroupStreamLambda block_size block_offset acc_params arr_params body = lam+ block_offset' = Imp.var block_offset int32+ w' <- ImpGen.compileSubExp w+ max_block_size <- ImpGen.compileSubExp maxchunk++ ImpGen.dLParams (acc_params++arr_params)+ zipWithM_ ImpGen.compileSubExpTo (map paramName acc_params) accs+ dPrim_ block_size int32++ -- If the GroupStream is morally just a do-loop, generate simpler code.+ case mapM isSimpleThreadInSpace $ stmsToList $ bodyStms body of+ Just stms' | ValueExp x <- max_block_size, oneIsh x -> do+ let body' = body { bodyStms = stmsFromList stms' }+ body'' = allThreads constants $+ ImpGen.compileLoopBody (map paramName acc_params) body'+ block_size <-- 1++ -- Check if loop is candidate for unrolling.+ let loop =+ case w of+ Var w_var | Just w_bound <- lookup w_var $ kernelStreamed constants,+ w_bound /= Imp.ConstSize 1 ->+ -- Candidate for unrolling, so generate two loops.+ sIf (w' .==. Imp.sizeToExp w_bound)+ (sFor block_offset Int32 (Imp.sizeToExp w_bound) body'')+ (sFor block_offset Int32 w' body'')+ _ -> sFor block_offset Int32 w' body''++ if kernelThreadActive constants == Imp.ValueExp (BoolValue True)+ then loop+ else sWhen (kernelThreadActive constants) loop++ _ -> do+ dPrim_ block_offset int32+ let body' = streaming constants block_size maxchunk $+ ImpGen.compileBody' acc_params body++ block_offset <-- 0++ let not_at_end = block_offset' .<. w'+ set_block_size =+ sIf (w' - block_offset' .<. max_block_size)+ (block_size <-- (w' - block_offset'))+ (block_size <-- max_block_size)+ increase_offset =+ block_offset <-- block_offset' + max_block_size++ -- Three cases to consider for simpler generated code based+ -- on max block size: (0) if full input size, do not+ -- generate a loop; (1) if one, generate for-loop (2)+ -- otherwise, generate chunked while-loop.+ if max_block_size == w' then+ (block_size <-- w') >> body'+ else if max_block_size == Imp.ValueExp (value (1::Int32)) then do+ block_size <-- w'+ sFor block_offset Int32 w' body'+ else+ sWhile not_at_end $+ set_block_size >> body' >> increase_offset++ forM_ (zip final acc_params) $ \(pe, p) ->+ ImpGen.copyDWIM (patElemName pe) [] (Var $ paramName p) []++ where isSimpleThreadInSpace (Let _ _ Op{}) = Nothing+ isSimpleThreadInSpace bnd = Just bnd++compileKernelExp _ _ (GroupGenReduce w arrs op bucket values locks) = do+ -- Check if bucket is in-bounds+ bucket' <- mapM ImpGen.compileSubExp bucket+ w' <- mapM ImpGen.compileSubExp w+ sWhen (indexInBounds bucket' w') $+ atomicUpdate arrs bucket op values locking+ where indexInBounds inds bounds =+ foldl1 (.&&.) $ zipWith checkBound inds bounds+ where checkBound ind bound = 0 .<=. ind .&&. ind .<. bound+ locking = Locking locks 0 1 0++compileKernelExp _ dest e =+ compilerBugS $ unlines ["Invalid target", " " ++ show dest,+ "for kernel expression", " " ++ pretty e]++-- | Locking strategy used for an atomic update.+data Locking = Locking { lockingArray :: VName -- ^ Array containing the lock.+ , lockingIsUnlocked :: Imp.Exp -- ^ Value for us to consider the lock free.+ , lockingToLock :: Imp.Exp -- ^ What to write when we lock it.+ , lockingToUnlock :: Imp.Exp -- ^ What to write when we unlock it.+ }++groupReduce :: ExplicitMemorish lore =>+ KernelConstants+ -> SubExp+ -> Lambda lore+ -> [VName]+ -> ImpGen.ImpM lore Imp.KernelOp ()+groupReduce constants w lam arrs = do+ w' <- ImpGen.compileSubExp w++ let local_tid = kernelLocalThreadId constants+ (reduce_i, reduce_j_param, actual_reduce_params) =+ partitionChunkedKernelLambdaParameters $ lambdaParams lam+ (reduce_acc_params, reduce_arr_params) =+ splitAt (length arrs) actual_reduce_params+ reduce_j = paramName reduce_j_param++ offset <- dPrim "offset" int32++ skip_waves <- dPrim "skip_waves" int32+ ImpGen.dLParams $ lambdaParams lam++ reduce_i <-- Imp.var local_tid int32++ let setOffset x = do+ offset <-- x+ reduce_j <-- Imp.var local_tid int32 + Imp.var offset int32++ setOffset 0++ sWhen (Imp.var local_tid int32 .<. w') $+ zipWithM_ (readReduceArgument offset) reduce_acc_params arrs++ let read_reduce_args = zipWithM_ (readReduceArgument offset)+ reduce_arr_params arrs+ do_reduce = do ImpGen.comment "read array element" read_reduce_args+ ImpGen.compileBody' reduce_acc_params $ lambdaBody lam+ zipWithM_ (writeReduceOpResult local_tid)+ reduce_acc_params arrs+ in_wave_reduce = ImpGen.everythingVolatile do_reduce++ wave_size = Imp.sizeToExp $ kernelWaveSize constants+ group_size = Imp.sizeToExp $ kernelGroupSize constants+ wave_id = Imp.var local_tid int32 `quot` wave_size+ in_wave_id = Imp.var local_tid int32 - wave_id * wave_size+ num_waves = (group_size + wave_size - 1) `quot` wave_size+ arg_in_bounds = Imp.var reduce_j int32 .<. w'++ doing_in_wave_reductions =+ Imp.var offset int32 .<. wave_size+ apply_in_in_wave_iteration =+ (in_wave_id .&. (2 * Imp.var offset int32 - 1)) .==. 0+ in_wave_reductions = do+ setOffset 1+ sWhile doing_in_wave_reductions $ do+ sWhen (arg_in_bounds .&&. apply_in_in_wave_iteration)+ in_wave_reduce+ setOffset $ Imp.var offset int32 * 2++ doing_cross_wave_reductions =+ Imp.var skip_waves int32 .<. num_waves+ is_first_thread_in_wave =+ in_wave_id .==. 0+ wave_not_skipped =+ (wave_id .&. (2 * Imp.var skip_waves int32 - 1)) .==. 0+ apply_in_cross_wave_iteration =+ arg_in_bounds .&&. is_first_thread_in_wave .&&. wave_not_skipped+ cross_wave_reductions = do+ skip_waves <-- 1+ sWhile doing_cross_wave_reductions $ do+ sOp Imp.Barrier+ setOffset (Imp.var skip_waves int32 * wave_size)+ sWhen apply_in_cross_wave_iteration+ do_reduce+ skip_waves <-- Imp.var skip_waves int32 * 2++ in_wave_reductions+ cross_wave_reductions+ where readReduceArgument offset param arr+ | Prim _ <- paramType param =+ ImpGen.copyDWIM (paramName param) [] (Var arr) [i]+ | otherwise =+ return ()+ where i = ImpGen.varIndex (kernelLocalThreadId constants) + ImpGen.varIndex offset++ writeReduceOpResult i param arr+ | Prim _ <- paramType param =+ ImpGen.copyDWIM arr [ImpGen.varIndex i] (Var $ paramName param) []+ | otherwise =+ return ()++atomicUpdate :: ExplicitMemorish lore =>+ [VName] -> [SubExp] -> Lambda lore -> [SubExp] -> Locking+ -> ImpGen.ImpM lore Imp.KernelOp ()+atomicUpdate [a] bucket op [v] _+ | [Prim t] <- lambdaReturnType op,+ primBitSize t == 32 = do+ -- If we have only one array and one non-array value (this is a+ -- one-to-one correspondance) then we need only one+ -- update. If operator has an atomic implementation we use+ -- that, otherwise it is still a binary operator which can+ -- be implemented by atomic compare-and-swap if 32 bits.++ -- Common variables.+ old <- dPrim "old" t+ bucket' <- mapM ImpGen.compileSubExp bucket++ (arr', _a_space, bucket_offset) <- ImpGen.fullyIndexArray a bucket'++ val' <- ImpGen.compileSubExp v+ case opHasAtomicSupport old arr' bucket_offset op of+ Just f -> sOp $ f val'++ Nothing -> do+ -- Code generation target:+ --+ -- old = d_his[idx];+ -- do {+ -- assumed = old;+ -- tmp = OP::apply(val, assumed);+ -- old = atomicCAS(&d_his[idx], assumed, tmp);+ -- } while(assumed != old);+ assumed <- dPrim "assumed" t+ run_loop <- dPrimV "run_loop" true+ ImpGen.copyDWIM old [] (Var a) bucket'++ -- Preparing parameters+ let (acc_p:arr_p:_) = lambdaParams op++ -- Critical section+ ImpGen.dLParams $ lambdaParams op++ -- While-loop: Try to insert your value+ let (toBits, fromBits) =+ case t of FloatType Float32 -> (\x -> Imp.FunExp "to_bits32" [x] int32,+ \x -> Imp.FunExp "from_bits32" [x] t)+ _ -> (id, id)+ sWhile (Imp.var run_loop Bool) $ do+ assumed <-- Imp.var old t+ paramName acc_p <-- val'+ paramName arr_p <-- Imp.var assumed t+ ImpGen.compileBody' [acc_p] $ lambdaBody op+ old_bits <- dPrim "old_bits" int32+ sOp $ Imp.Atomic $+ Imp.AtomicCmpXchg old_bits arr' bucket_offset+ (toBits (Imp.var assumed int32)) (toBits (Imp.var (paramName acc_p) int32))+ old <-- fromBits (Imp.var old_bits int32)+ sWhen (toBits (Imp.var assumed t) .==. Imp.var old_bits int32)+ (run_loop <-- false)+ where opHasAtomicSupport old arr' bucket' lam = do+ let atomic f = Imp.Atomic . f old arr' bucket'+ [BasicOp (BinOp bop _ _)] <-+ Just $ map stmExp $ stmsToList $ bodyStms $ lambdaBody lam+ atomic <$> Imp.atomicBinOp bop++atomicUpdate arrs bucket op values locking = do+ old <- dPrim "old" int32+ loop_done <- dPrimV "loop_done" 0++ -- Check if bucket is in-bounds+ bucket' <- mapM ImpGen.compileSubExp bucket++ -- Correctly index into locks.+ (locks', _locks_space, locks_offset) <-+ ImpGen.fullyIndexArray (lockingArray locking) bucket'++ -- Preparing parameters+ let (acc_params, arr_params) =+ splitAt (length values) $ lambdaParams op++ -- Critical section+ let try_acquire_lock =+ sOp $ Imp.Atomic $+ Imp.AtomicCmpXchg old locks' locks_offset (lockingIsUnlocked locking) (lockingToLock locking)+ lock_acquired = Imp.var old int32 .==. lockingIsUnlocked locking+ loop_cond = Imp.var loop_done int32 .==. 0+ release_lock = ImpGen.everythingVolatile $+ ImpGen.sWrite (lockingArray locking) bucket' $ lockingToUnlock locking+ break_loop = loop_done <-- 1++ -- We copy the current value and the new value to the parameters+ -- unless they are array-typed. If they are arrays, then the+ -- index functions should already be set up correctly, so there is+ -- nothing more to do.+ let bind_acc_params =+ forM_ (zip acc_params arrs) $ \(acc_p, arr) ->+ when (primType (paramType acc_p)) $+ ImpGen.copyDWIM (paramName acc_p) [] (Var arr) bucket'++ let bind_arr_params =+ forM_ (zip arr_params values) $ \(arr_p, val) ->+ when (primType (paramType arr_p)) $+ ImpGen.copyDWIM (paramName arr_p) [] val []++ let op_body = ImpGen.compileBody' acc_params $ lambdaBody op++ do_gen_reduce = zipWithM_ (writeArray bucket') arrs $ map (Var . paramName) acc_params++ -- While-loop: Try to insert your value+ sWhile loop_cond $ do+ try_acquire_lock+ sWhen lock_acquired $ do+ ImpGen.dLParams $ lambdaParams op+ bind_acc_params+ bind_arr_params+ op_body+ do_gen_reduce+ release_lock+ break_loop+ sOp Imp.MemFence+ where writeArray bucket' arr val =+ ImpGen.copyDWIM arr bucket' val []++allThreads :: KernelConstants -> InKernelGen () -> InKernelGen ()+allThreads constants = ImpGen.emit <=< ImpGen.subImpM_ (inKernelOperations constants')+ where constants' =+ constants { kernelThreadActive = Imp.ValueExp (BoolValue True) }++streaming :: KernelConstants -> VName -> SubExp -> InKernelGen () -> InKernelGen ()+streaming constants chunksize bound m = do+ bound' <- ImpGen.subExpToDimSize bound+ let constants' =+ constants { kernelStreamed = (chunksize, bound') : kernelStreamed constants }+ ImpGen.emit =<< ImpGen.subImpM_ (inKernelOperations constants') m++compileKernelResult :: KernelConstants -> PatElem InKernel -> KernelResult+ -> InKernelGen ()++compileKernelResult constants pe (ThreadsReturn OneResultPerGroup what) = do+ i <- newVName "i"++ in_local_memory <- arrayInLocalMemory what+ let me = Imp.var (kernelLocalThreadId constants) int32++ if not in_local_memory then do+ who' <- ImpGen.compileSubExp $ intConst Int32 0+ sWhen (me .==. who') $+ ImpGen.copyDWIM (patElemName pe) [ImpGen.varIndex $ kernelGroupId constants] what []+ else do+ -- If the result of the group is an array in local memory, we+ -- store it by collective copying among all the threads of the+ -- group. TODO: also do this if the array is in global memory+ -- (but this is a bit more tricky, synchronisation-wise).+ --+ -- We do the reads/writes multidimensionally, but the loop is+ -- single-dimensional.+ ws <- mapM ImpGen.compileSubExp . arrayDims =<< subExpType what+ -- Compute how many elements this thread is responsible for.+ -- Formula: (w - ltid) / group_size (rounded up).+ let w = product ws+ ltid = ImpGen.varIndex (kernelLocalThreadId constants)+ group_size = Imp.sizeToExp (kernelGroupSize constants)+ to_write = (w - ltid) `quotRoundingUp` group_size+ is = unflattenIndex ws $ ImpGen.varIndex i * group_size + ltid++ sFor i Int32 to_write $+ ImpGen.copyDWIM (patElemName pe) (ImpGen.varIndex (kernelGroupId constants) : is) what is++compileKernelResult constants pe (ThreadsReturn AllThreads what) =+ ImpGen.copyDWIM (patElemName pe) [ImpGen.varIndex $ kernelGlobalThreadId constants] what []++compileKernelResult constants pe (ThreadsReturn (ThreadsPerGroup limit) what) =+ sWhen (isActive limit) $+ ImpGen.copyDWIM (patElemName pe) [ImpGen.varIndex $ kernelGroupId constants] what []++compileKernelResult constants pe (ThreadsReturn ThreadsInSpace what) = do+ let is = map (ImpGen.varIndex . fst) $ kernelDimensions constants+ sWhen (kernelThreadActive constants) $ ImpGen.copyDWIM (patElemName pe) is what []++compileKernelResult constants pe (ConcatReturns SplitContiguous _ per_thread_elems moffset what) = do+ dest_loc <- ImpGen.entryArrayLocation <$> ImpGen.lookupArray (patElemName pe)+ let dest_loc_offset = ImpGen.offsetArray dest_loc offset+ dest' = ImpGen.arrayDestination dest_loc_offset+ ImpGen.copyDWIMDest dest' [] (Var what) []+ where offset = case moffset of+ Nothing -> ImpGen.compileSubExpOfType int32 per_thread_elems *+ ImpGen.varIndex (kernelGlobalThreadId constants)+ Just se -> ImpGen.compileSubExpOfType int32 se++compileKernelResult constants pe (ConcatReturns (SplitStrided stride) _ _ moffset what) = do+ dest_loc <- ImpGen.entryArrayLocation <$> ImpGen.lookupArray (patElemName pe)+ let dest_loc' = ImpGen.strideArray+ (ImpGen.offsetArray dest_loc offset) $+ ImpGen.compileSubExpOfType int32 stride+ dest' = ImpGen.arrayDestination dest_loc'+ ImpGen.copyDWIMDest dest' [] (Var what) []+ where offset = case moffset of+ Nothing -> ImpGen.varIndex (kernelGlobalThreadId constants)+ Just se -> ImpGen.compileSubExpOfType int32 se++compileKernelResult constants pe (WriteReturn rws _arr dests) = do+ rws' <- mapM ImpGen.compileSubExp rws+ forM_ dests $ \(is, e) -> do+ is' <- mapM ImpGen.compileSubExp is+ let condInBounds i rw = 0 .<=. i .&&. i .<. rw+ write = foldl (.&&.) (kernelThreadActive constants) $+ zipWith condInBounds is' rws'+ sWhen write $ ImpGen.copyDWIM (patElemName pe) (map (ImpGen.compileSubExpOfType int32) is) e []++compileKernelResult _ _ KernelInPlaceReturn{} =+ -- Already in its place... said it was a hack.+ return ()++isActive :: [(VName, SubExp)] -> Imp.Exp+isActive limit = case actives of+ [] -> Imp.ValueExp $ BoolValue True+ x:xs -> foldl (.&&.) x xs+ where (is, ws) = unzip limit+ actives = zipWith active is $ map (ImpGen.compileSubExpOfType Bool) ws+ active i = (Imp.var i int32 .<.)++setSpaceIndices :: KernelSpace -> InKernelGen ()+setSpaceIndices space =+ case spaceStructure space of+ FlatThreadSpace is_and_dims ->+ flatSpaceWith gtid is_and_dims+ NestedThreadSpace is_and_dims -> do+ let (gtids, gdims, ltids, ldims) = unzip4 is_and_dims+ gdims' <- mapM ImpGen.compileSubExp gdims+ ldims' <- mapM ImpGen.compileSubExp ldims+ let (gtid_es, ltid_es) = unzip $ unflattenNestedIndex gdims' ldims' gtid+ zipWithM_ (<--) gtids gtid_es+ zipWithM_ (<--) ltids ltid_es+ where gtid = Imp.var (spaceGlobalId space) int32++ flatSpaceWith base is_and_dims = do+ let (is, dims) = unzip is_and_dims+ dims' <- mapM ImpGen.compileSubExp dims+ let index_expressions = unflattenIndex dims' base+ zipWithM_ (<--) is index_expressions unflattenNestedIndex :: IntegralExp num => [num] -> [num] -> num -> [(num,num)] unflattenNestedIndex global_dims group_dims global_id =
src/Futhark/CodeGen/ImpGen/Kernels/ToOpenCL.hs view
@@ -20,8 +20,6 @@ import qualified Language.C.Quote.OpenCL as C import Futhark.Error-import Futhark.Representation.AST.Attributes.Types (int32)-import qualified Futhark.CodeGen.OpenCL.Kernels as Kernels import qualified Futhark.CodeGen.Backends.GenericC as GenericC import Futhark.CodeGen.Backends.SimpleRepresentation import Futhark.CodeGen.ImpCode.Kernels hiding (Program)@@ -31,7 +29,6 @@ import Futhark.MonadFreshNames import Futhark.Util (zEncodeString) import Futhark.Util.Pretty (pretty, prettyOneLine)-import Futhark.Util.IntegralExp (quotRoundingUp) -- | Translate a kernels-program to an OpenCL-program. kernelsToOpenCL :: ImpKernels.Program@@ -128,7 +125,9 @@ return $ LaunchKernel (calledKernelName called) (kernelArgs called) kernel_size workgroup_size - where (kernel_size, workgroup_size) = kernelAndWorkgroupSize called+ where kernel_size = [sizeToExp (mapKernelNumGroups kernel) *+ sizeToExp (mapKernelGroupSize kernel)]+ workgroup_size = [sizeToExp $ mapKernelGroupSize kernel] onKernel called@(AnyKernel kernel) = do let (kernel_body, _) =@@ -167,18 +166,8 @@ return (Nothing, [C.citem|ALIGNED_LOCAL_MEMORY($id:mem, $exp:size');|]) name = calledKernelName called- (kernel_size, workgroup_size) = kernelAndWorkgroupSize called--onKernel (MapTranspose bt- destmem destoffset- srcmem srcoffset- num_arrays x_elems y_elems in_elems out_elems) = do- generateTransposeFunction bt- return $ HostCode $ Call [] (transposeName bt)- [MemArg destmem, ExpArg destoffset,- MemArg srcmem, ExpArg srcoffset,- ExpArg num_arrays, ExpArg x_elems, ExpArg y_elems,- ExpArg in_elems, ExpArg out_elems]+ kernel_size = zipWith (*) (kernelNumGroups kernel) (kernelGroupSize kernel)+ workgroup_size = kernelGroupSize kernel useAsParam :: KernelUse -> Maybe C.Param useAsParam (ScalarUse name bt) =@@ -187,7 +176,7 @@ Bool -> [C.cty|unsigned char|] _ -> GenericC.primTypeToCType bt in Just [C.cparam|$ty:ctp $id:name|]-useAsParam (MemoryUse name _) =+useAsParam (MemoryUse name) = Just [C.cparam|__global unsigned char *$id:name|] useAsParam ConstUse{} = Nothing@@ -249,9 +238,7 @@ calledKernelName (Map k) = mapKernelName k calledKernelName (AnyKernel k) =- kernelDesc k ++ "_kernel_" ++ show (baseTag $ kernelName k)-calledKernelName (MapTranspose bt _ _ _ _ _ _ _ _ _) =- transposeKernelName bt Kernels.TransposeNormal+ nameToString $ kernelName k kernelArgs :: CallKernel -> [KernelArg] kernelArgs (Map kernel) =@@ -262,33 +249,7 @@ mapMaybe useToArg (kernelUses kernel) where localMemorySize (_, Left size) = Just size localMemorySize (_, Right{}) = Nothing-kernelArgs (MapTranspose bt destmem destoffset srcmem srcoffset _ x_elems y_elems in_elems out_elems) =- [ MemKArg destmem- , ValueKArg destoffset int32- , MemKArg srcmem- , ValueKArg srcoffset int32- , ValueKArg x_elems int32- , ValueKArg y_elems int32- , ValueKArg in_elems int32- , ValueKArg out_elems int32- , SharedMemoryKArg shared_memory- ]- where shared_memory =- bytes $ (transposeBlockDim + 1) * transposeBlockDim *- LeafExp (SizeOf bt) (IntType Int32) -kernelAndWorkgroupSize :: CallKernel -> ([Exp], [Exp])-kernelAndWorkgroupSize (Map kernel) =- ([sizeToExp (mapKernelNumGroups kernel) *- sizeToExp (mapKernelGroupSize kernel)],- [sizeToExp $ mapKernelGroupSize kernel])-kernelAndWorkgroupSize (AnyKernel kernel) =- ([sizeToExp (kernelNumGroups kernel) *- sizeToExp (kernelGroupSize kernel)],- [sizeToExp $ kernelGroupSize kernel])-kernelAndWorkgroupSize (MapTranspose _ _ _ _ _ num_arrays x_elems y_elems _ _) =- transposeKernelAndGroupSize num_arrays x_elems y_elems- --- Generating C inKernelOperations :: GenericC.Operations KernelOp UsedFunctions@@ -393,213 +354,16 @@ quals <- pointerQuals space return [C.cty|$tyquals:quals $ty:defaultMemBlockType|] ---- Handling transpositions--transposeKernelName :: PrimType -> Kernels.TransposeType -> String-transposeKernelName bt Kernels.TransposeNormal =- "fut_kernel_map_transpose_" ++ pretty bt-transposeKernelName bt Kernels.TransposeLowWidth =- "fut_kernel_map_transpose_lowwidth_" ++ pretty bt-transposeKernelName bt Kernels.TransposeLowHeight =- "fut_kernel_map_transpose_lowheight_" ++ pretty bt-transposeKernelName bt Kernels.TransposeSmall =- "fut_kernel_map_transpose_small_" ++ pretty bt--transposeName :: PrimType -> Name-transposeName bt = nameFromString $ "map_transpose_opencl_" ++ pretty bt--generateTransposeFunction :: PrimType -> OnKernelM ()-generateTransposeFunction bt =- -- We have special functions to handle transposing an input array with low- -- width or low height, as this would cause very few threads to be active. See- -- comment in Futhark.CodeGen.OpenCL.OpenCL.Kernels.hs for more details.-- tell mempty- { clExtraFuns = M.singleton (transposeName bt) $- ImpOpenCL.Function False [] params transpose_code [] []- , clKernels = M.fromList $- map (\tt -> let name = transposeKernelName bt tt- in (name, Kernels.mapTranspose name bt' tt))- [Kernels.TransposeNormal, Kernels.TransposeLowWidth,- Kernels.TransposeLowHeight, Kernels.TransposeSmall]-- , clRequirements = mempty- }-- where bt' = GenericC.primTypeToCType bt- space = ImpOpenCL.Space "device"- memparam s i = MemParam (VName (nameFromString s) i) space- intparam s i = ScalarParam (VName (nameFromString s) i) $ IntType Int32-- params = [destmem_p, destoffset_p, srcmem_p, srcoffset_p,- num_arrays_p, x_p, y_p, in_p, out_p]-- [destmem_p, destoffset_p, srcmem_p, srcoffset_p,- num_arrays_p, x_p, y_p, in_p, out_p,- muly, new_height, mulx, new_width] =- zipWith ($) [memparam "destmem",- intparam "destoffset",- memparam "srcmem",- intparam "srcoffset",- intparam "num_arrays",- intparam "x_elems",- intparam "y_elems",- intparam "in_elems",- intparam "out_elems",- -- The following is only used for low width/height- -- transpose kernels- intparam "muly",- intparam "new_height",- intparam "mulx",- intparam "new_width"- ]- [0..]-- asExp param =- ImpOpenCL.LeafExp (ImpOpenCL.ScalarVar (paramName param)) (IntType Int32)-- asArg (MemParam name _) =- MemKArg name- asArg (ScalarParam name t) =- ValueKArg (ImpOpenCL.LeafExp (ImpOpenCL.ScalarVar name) t) t-- normal_kernel_args =- map asArg [destmem_p, destoffset_p, srcmem_p, srcoffset_p,- x_p, y_p, in_p, out_p] ++- [SharedMemoryKArg shared_memory]-- lowwidth_kernel_args =- map asArg [destmem_p, destoffset_p, srcmem_p, srcoffset_p,- x_p, y_p, in_p, out_p, muly] ++- [SharedMemoryKArg shared_memory]-- lowheight_kernel_args =- map asArg [destmem_p, destoffset_p, srcmem_p, srcoffset_p,- x_p, y_p, in_p, out_p, mulx] ++- [SharedMemoryKArg shared_memory]-- shared_memory =- bytes $ (transposeBlockDim + 1) * transposeBlockDim *- LeafExp (SizeOf bt) (IntType Int32)-- transposeBlockDimDivTwo = BinOpExp (SQuot Int32) transposeBlockDim 2-- should_use_lowwidth = BinOpExp LogAnd- (CmpOpExp (CmpSle Int32) (asExp x_p) transposeBlockDimDivTwo)- (CmpOpExp (CmpSlt Int32) transposeBlockDim (asExp y_p))-- should_use_lowheight = BinOpExp LogAnd- (CmpOpExp (CmpSle Int32) (asExp y_p) transposeBlockDimDivTwo)- (CmpOpExp (CmpSlt Int32) transposeBlockDim (asExp x_p))-- should_use_small = BinOpExp LogAnd- (CmpOpExp (CmpSle Int32) (asExp x_p) transposeBlockDimDivTwo)- (CmpOpExp (CmpSle Int32) (asExp y_p) transposeBlockDimDivTwo)-- -- When an input array has either width==1 or height==1, performing a- -- transpose will be the same as performing a copy. If 'input_size' or- -- 'output_size' is not equal to width*height, then this trick will not- -- work when there are more than one array to process, as it is a per- -- array limit. We could copy each array individually, but currently we- -- do not.- can_use_copy =- let in_out_eq = CmpOpExp (CmpEq $ IntType Int32) (asExp in_p) (asExp out_p)- onearr = CmpOpExp (CmpEq $ IntType Int32) (asExp num_arrays_p) 1- noprob_widthheight = CmpOpExp (CmpEq $ IntType Int32)- (asExp x_p * asExp y_p)- (asExp in_p)- height_is_one = CmpOpExp (CmpEq $ IntType Int32) (asExp y_p) 1- width_is_one = CmpOpExp (CmpEq $ IntType Int32) (asExp x_p) 1- in BinOpExp LogAnd- in_out_eq- (BinOpExp LogAnd- (BinOpExp LogOr onearr noprob_widthheight)- (BinOpExp LogOr width_is_one height_is_one))-- input_is_empty = CmpOpExp (CmpEq $ IntType Int32)- (asExp num_arrays_p * asExp x_p * asExp y_p) 0-- transpose_code =- ImpOpenCL.If input_is_empty mempty- (ImpOpenCL.If can_use_copy- copy_code- (ImpOpenCL.If should_use_lowwidth- lowwidth_transpose_code- (ImpOpenCL.If should_use_lowheight- lowheight_transpose_code- (ImpOpenCL.If should_use_small- small_transpose_code- normal_transpose_code))))-- copy_code =- let num_bytes =- asExp in_p * ImpOpenCL.LeafExp (ImpOpenCL.SizeOf bt) (IntType Int32)- in ImpOpenCL.Copy- (paramName destmem_p) (Count $ asExp destoffset_p) space- (paramName srcmem_p) (Count $ asExp srcoffset_p) space- (Count num_bytes)-- normal_transpose_code =- let (kernel_size, workgroup_size) =- transposeKernelAndGroupSize (asExp num_arrays_p) (asExp x_p) (asExp y_p)- in ImpOpenCL.Op $ LaunchKernel- (transposeKernelName bt Kernels.TransposeNormal) normal_kernel_args kernel_size workgroup_size-- small_transpose_code =- let group_size = (transposeBlockDim * transposeBlockDim)- kernel_size = (asExp num_arrays_p * asExp x_p * asExp y_p) `roundUpTo`- group_size- in ImpOpenCL.Op $ LaunchKernel- (transposeKernelName bt Kernels.TransposeSmall)- (map asArg [destmem_p, destoffset_p, srcmem_p, srcoffset_p,- num_arrays_p, x_p, y_p, in_p, out_p])- [kernel_size] [group_size]-- lowwidth_transpose_code =- let set_muly = DeclareScalar (paramName muly) (IntType Int32)- :>>: SetScalar (paramName muly) (BinOpExp (SQuot Int32) transposeBlockDim (asExp x_p))- set_new_height = DeclareScalar (paramName new_height) (IntType Int32)- :>>: SetScalar (paramName new_height) (asExp y_p `quotRoundingUp` asExp muly)- (kernel_size, workgroup_size) =- transposeKernelAndGroupSize (asExp num_arrays_p) (asExp x_p) (asExp new_height)- launch = ImpOpenCL.Op $ LaunchKernel- (transposeKernelName bt Kernels.TransposeLowWidth) lowwidth_kernel_args kernel_size workgroup_size- in set_muly :>>: set_new_height :>>: launch-- lowheight_transpose_code =- let set_mulx = DeclareScalar (paramName mulx) (IntType Int32)- :>>: SetScalar (paramName mulx) (BinOpExp (SQuot Int32) transposeBlockDim (asExp y_p))- set_new_width = DeclareScalar (paramName new_width) (IntType Int32)- :>>: SetScalar (paramName new_width) (asExp x_p `quotRoundingUp` asExp mulx)- (kernel_size, workgroup_size) =- transposeKernelAndGroupSize (asExp num_arrays_p) (asExp new_width) (asExp y_p)- launch = ImpOpenCL.Op $ LaunchKernel- (transposeKernelName bt Kernels.TransposeLowHeight) lowheight_kernel_args kernel_size workgroup_size- in set_mulx :>>: set_new_width :>>: launch--transposeKernelAndGroupSize :: ImpOpenCL.Exp -> ImpOpenCL.Exp -> ImpOpenCL.Exp- -> ([ImpOpenCL.Exp], [ImpOpenCL.Exp])-transposeKernelAndGroupSize num_arrays x_elems y_elems =- ([(x_elems `roundUpTo` transposeBlockDim) *- (y_elems `roundUpTo` transposeBlockDim) *- num_arrays],- [transposeBlockDim * transposeBlockDim])--roundUpTo :: ImpOpenCL.Exp -> ImpOpenCL.Exp -> ImpOpenCL.Exp-roundUpTo x y = x + ((y - (x `impRem` y)) `impRem` y)- where impRem = BinOpExp $ SRem Int32- --- Checking requirements useToArg :: KernelUse -> Maybe KernelArg-useToArg (MemoryUse mem _) = Just $ MemKArg mem-useToArg (ScalarUse v bt) = Just $ ValueKArg (LeafExp (ScalarVar v) bt) bt-useToArg ConstUse{} = Nothing+useToArg (MemoryUse mem) = Just $ MemKArg mem+useToArg (ScalarUse v bt) = Just $ ValueKArg (LeafExp (ScalarVar v) bt) bt+useToArg ConstUse{} = Nothing typesInKernel :: CallKernel -> S.Set PrimType typesInKernel (Map kernel) = typesInCode $ mapKernelBody kernel typesInKernel (AnyKernel kernel) = typesInCode $ kernelBody kernel-typesInKernel MapTranspose{} = mempty typesInCode :: ImpKernels.KernelCode -> S.Set PrimType typesInCode Skip = mempty
+ src/Futhark/CodeGen/ImpGen/Kernels/Transpose.hs view
@@ -0,0 +1,277 @@+module Futhark.CodeGen.ImpGen.Kernels.Transpose+ ( TransposeType(..)+ , TransposeArgs+ , mapTranspose+ , mapTransposeKernel+ )+ where++import qualified Data.Set as S+import Data.Semigroup ((<>))++import Prelude hiding (quot, rem)++import Futhark.CodeGen.ImpCode.Kernels+import Futhark.Representation.AST.Attributes.Types+import Futhark.Representation.AST.Attributes.Names (freeIn)+import Futhark.Util.IntegralExp (IntegralExp, quot, rem, quotRoundingUp)++-- | Which form of transposition to generate code for.+data TransposeType = TransposeNormal+ | TransposeLowWidth+ | TransposeLowHeight+ | TransposeSmall -- ^ For small arrays that do not+ -- benefit from coalescing.+ deriving (Eq, Ord, Show)++type TransposeArgs = (VName, Exp,+ VName, Exp,+ Exp, Exp, Exp, Exp,+ Exp, Exp, Exp,+ VName)++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+ TransposeSmall ->+ mconcat+ [ get_ids++ , dec our_array_offset $ v32 get_global_id_0 `quot` (height*width) * (height*width)++ , dec x_index $ (v32 get_global_id_0 `rem` (height*width)) `quot` height+ , dec y_index $ v32 get_global_id_0 `rem` height++ , dec odata_offset $+ (basic_odata_offset `quot` primByteSize t) + v32 our_array_offset+ , dec idata_offset $+ (basic_idata_offset `quot` primByteSize t) + v32 our_array_offset++ , dec index_in $ v32 y_index * width + v32 x_index+ , dec index_out $ v32 x_index * height + v32 y_index++ , If (v32 get_global_id_0 .<. input_size)+ (Write odata (bytes $ (v32 odata_offset + v32 index_out) * tsize) t (Space "global") Nonvolatile $+ index idata (bytes $ (v32 idata_offset + v32 index_in) * tsize) t (Space "global") Nonvolatile)+ mempty+ ]++ TransposeLowWidth ->+ mkTranspose $ lowDimBody+ (v32 get_group_id_0 * block_dim + (v32 get_local_id_0 `quot` muly))+ (v32 get_group_id_1 * block_dim * muly + v32 get_local_id_1 ++ (v32 get_local_id_0 `rem` muly) * block_dim)+ (v32 get_group_id_1* block_dim * muly + v32 get_local_id_0 ++ (v32 get_local_id_1 `rem` muly) * block_dim)+ (v32 get_group_id_0 * block_dim + (v32 get_local_id_1 `quot` muly))++ TransposeLowHeight ->+ mkTranspose $ lowDimBody+ (v32 get_group_id_0 * block_dim * mulx + v32 get_local_id_0 ++ (v32 get_local_id_1 `rem` mulx) * block_dim)+ (v32 get_group_id_1 * block_dim + (v32 get_local_id_1 `quot` mulx))+ (v32 get_group_id_1 * block_dim + (v32 get_local_id_0 `quot` mulx))+ (v32 get_group_id_0 * block_dim * mulx + v32 get_local_id_1 ++ (v32 get_local_id_0 `rem` mulx) * block_dim)++ TransposeNormal ->+ mkTranspose $ mconcat+ [ dec x_index $ v32 get_global_id_0+ , dec y_index $ v32 get_group_id_1 * tile_dim + v32 get_local_id_1+ , when (v32 x_index .<. width) $+ For j Int32 elemsPerThread $+ let i = v32 j * (tile_dim `quot` elemsPerThread)+ in mconcat [ dec index_in $ (v32 y_index + i) * width + v32 x_index+ , when (v32 y_index + i .<. height .&&.+ v32 index_in .<. input_size) $+ Write block (bytes $ ((v32 get_local_id_1 + i) * (tile_dim+1)+ + v32 get_local_id_0) * tsize)+ t (Space "local") Nonvolatile $+ index idata (bytes $ (v32 idata_offset + v32 index_in) * tsize)+ t (Space "global") Nonvolatile]+ , Op Barrier+ , SetScalar x_index $ v32 get_group_id_1 * tile_dim + v32 get_local_id_0+ , SetScalar y_index $ v32 get_group_id_0 * tile_dim + v32 get_local_id_1+ , when (v32 x_index .<. height) $+ For j Int32 elemsPerThread $+ let i = v32 j * (tile_dim `quot` elemsPerThread)+ in mconcat [ dec index_out $ (v32 y_index + i) * height + v32 x_index+ , when (v32 y_index + i .<. width .&&.+ v32 index_out .<. output_size) $+ Write odata (bytes $ (v32 odata_offset + v32 index_out) * tsize)+ t (Space "global") Nonvolatile $+ index block (bytes $ (v32 get_local_id_0 * (tile_dim+1)+ +v32 get_local_id_1+i)*tsize)+ t (Space "local") Nonvolatile+ ]+ ]++ where dec v e = DeclareScalar v int32 <> SetScalar v e+ v32 = flip var int32+ tsize = LeafExp (SizeOf t) int32+ tile_dim = 2 * block_dim++ when a b = If a b mempty++ (odata, basic_odata_offset, idata, basic_idata_offset,+ width, height, input_size, output_size,+ mulx, muly, _num_arrays, block) = args++ -- Be extremely careful when editing this list to ensure that+ -- the names match up. Also, be careful that the tags on+ -- these names do not conflicts with the tags of the+ -- surrounding code. We accomplish the latter by using very+ -- low tags (normal variables start at least in the low+ -- hundreds).+ [ our_array_offset , x_index , y_index+ , odata_offset, idata_offset, index_in, index_out+ , get_global_id_0+ , get_local_id_0, get_local_id_1+ , get_group_id_0, get_group_id_1, get_group_id_2+ , j] =+ zipWith (flip VName) [30..] $ map nameFromString+ [ "our_array_offset" , "x_index" , "y_index"+ , "odata_offset", "idata_offset", "index_in", "index_out"+ , "get_global_id_0"+ , "get_local_id_0", "get_local_id_1"+ , "get_group_id_0", "get_group_id_1", "get_group_id_2"+ , "j"]++ get_ids =+ mconcat [ DeclareScalar get_global_id_0 int32+ , Op $ GetGlobalId get_global_id_0 0+ , DeclareScalar get_local_id_0 int32+ , Op $ GetLocalId get_local_id_0 0+ , DeclareScalar get_local_id_1 int32+ , Op $ GetLocalId get_local_id_1 1+ , DeclareScalar get_group_id_0 int32+ , Op $ GetGroupId get_group_id_0 0+ , DeclareScalar get_group_id_1 int32+ , Op $ GetGroupId get_group_id_1 1+ , DeclareScalar get_group_id_2 int32+ , Op $ GetGroupId get_group_id_2 2+ ]++ mkTranspose body =+ mconcat+ [ get_ids+ , dec our_array_offset $ v32 get_group_id_2 * width * height+ , dec odata_offset $+ (basic_odata_offset `quot` primByteSize t) + v32 our_array_offset+ , dec idata_offset $+ (basic_idata_offset `quot` primByteSize t) + v32 our_array_offset+ , body+ ]++ lowDimBody x_in_index y_in_index x_out_index y_out_index =+ mconcat+ [ dec x_index x_in_index+ , dec y_index y_in_index+ , dec index_in $ v32 y_index * width + v32 x_index+ , when (v32 x_index .<. width .&&. v32 y_index .<. height .&&. v32 index_in .<. input_size) $+ Write block (bytes $ (v32 get_local_id_1 * (block_dim+1) + v32 get_local_id_0) * tsize)+ t (Space "local") Nonvolatile $+ index idata (bytes $ (v32 idata_offset + v32 index_in) * tsize)+ t (Space "global") Nonvolatile+ , Op Barrier+ , SetScalar x_index x_out_index+ , SetScalar y_index y_out_index+ , dec index_out $ v32 y_index * height + v32 x_index+ , when (v32 x_index .<. height .&&. v32 y_index .<. width .&&. v32 index_out .<. output_size) $+ Write odata (bytes $ (v32 odata_offset + v32 index_out) * tsize)+ t (Space "global") Nonvolatile $+ index block (bytes $ (v32 get_local_id_0 * (block_dim+1)+ +v32 get_local_id_1)*tsize)+ t (Space "local") Nonvolatile+ ]++mapTransposeKernel :: String -> Integer -> TransposeArgs -> PrimType -> TransposeType+ -> Kernel+mapTransposeKernel desc block_dim_int args t kind =+ Kernel+ { kernelBody = mapTranspose block_dim args t kind+ , kernelLocalMemory = [(block, Right block_size)]+ , kernelUses = uses+ , kernelNumGroups = num_groups+ , kernelGroupSize = group_size+ , kernelName = nameFromString name+ }+ where pad2DBytes k = k * (k + 1) * primByteSize t+ block_size =+ case kind of TransposeSmall -> 1 -- Not used, but AMD's+ -- OpenCL does not like+ -- zero-size local memory.+ TransposeNormal -> fromInteger $ pad2DBytes $ 2*block_dim_int+ TransposeLowWidth -> fromInteger $ pad2DBytes block_dim_int+ TransposeLowHeight -> fromInteger $ pad2DBytes block_dim_int+ block_dim = fromInteger block_dim_int++ (odata, basic_odata_offset, idata, basic_idata_offset,+ width, height, input_size, output_size,+ mulx, muly, num_arrays,+ block) = args++ (num_groups, group_size) =+ case kind of+ TransposeSmall ->+ ([(num_arrays * width * height) `quotRoundingUp` (block_dim * block_dim)],+ [block_dim * block_dim])+ TransposeLowWidth ->+ lowDimKernelAndGroupSize block_dim num_arrays width $ height `quotRoundingUp` muly+ TransposeLowHeight ->+ lowDimKernelAndGroupSize block_dim num_arrays (width `quotRoundingUp` mulx) height+ TransposeNormal ->+ let actual_dim = block_dim*2+ in ( [ width `quotRoundingUp` actual_dim+ , height `quotRoundingUp` actual_dim+ , num_arrays]+ , [actual_dim, actual_dim `quot` elemsPerThread, 1])++ uses = map (`ScalarUse` int32)+ (S.toList $ mconcat $ map freeIn+ [basic_odata_offset, basic_idata_offset, num_arrays,+ width, height, input_size, output_size, mulx, muly]) +++ map MemoryUse [odata, idata]++ name =+ case kind of TransposeSmall -> desc ++ "_small"+ TransposeLowHeight -> desc ++ "_low_height"+ TransposeLowWidth -> desc ++ "_low_width"+ TransposeNormal -> desc++lowDimKernelAndGroupSize :: Exp -> Exp -> Exp -> Exp -> ([Exp], [Exp])+lowDimKernelAndGroupSize block_dim num_arrays x_elems y_elems =+ ([x_elems `quotRoundingUp` block_dim,+ y_elems `quotRoundingUp` block_dim,+ num_arrays],+ [block_dim, block_dim, 1])
src/Futhark/CodeGen/OpenCL/Kernels.hs view
@@ -1,19 +1,12 @@-{-# LANGUAGE QuasiQuotes #-} module Futhark.CodeGen.OpenCL.Kernels ( SizeHeuristic (..) , DeviceType (..) , WhichSize (..) , HeuristicValue (..) , sizeHeuristicsTable-- , mapTranspose- , TransposeType(..) ) where -import qualified Language.C.Syntax as C-import qualified Language.C.Quote.OpenCL as C- -- 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@@ -60,171 +53,3 @@ , SizeHeuristic "" DeviceCPU GroupSize $ HeuristicConst 32 , SizeHeuristic "" DeviceCPU TileSize $ HeuristicConst 4 ]---- | Which form of transposition to generate code for.-data TransposeType = TransposeNormal- | TransposeLowWidth- | TransposeLowHeight- | TransposeSmall -- ^ For small arrays that do not- -- benefit from coalescing.- deriving (Eq, Ord, Show)---- | @mapTranspose name elem_type transpose_type@ Generate a transpose kernel--- with requested @name@ for elements of type @elem_type@. There are special--- support to handle input arrays with low width or low height, which can be--- indicated by @transpose_type@.------ 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.-mapTranspose :: C.ToIdent a => a -> C.Type -> TransposeType -> C.Func-mapTranspose kernel_name elem_type transpose_type =- case transpose_type of- TransposeNormal ->- bigKernel []- [C.cexp|global_id_x|]- [C.cexp|global_id_y|]- [C.cexp|group_id_y * FUT_BLOCK_DIM + local_id_x|]- [C.cexp|group_id_x * FUT_BLOCK_DIM + local_id_y|]- (toNumGroups [C.cexp|width|])- (toNumGroups [C.cexp|height|])- TransposeLowWidth ->- bigKernel [C.cparams|uint muly|]- [C.cexp|group_id_x * FUT_BLOCK_DIM + (local_id_x / muly)|]- [C.cexp|group_id_y * FUT_BLOCK_DIM * muly- + local_id_y- + (local_id_x % muly) * FUT_BLOCK_DIM- |]- [C.cexp|group_id_y * FUT_BLOCK_DIM * muly- + local_id_x- + (local_id_y % muly) * FUT_BLOCK_DIM|]- [C.cexp|group_id_x * FUT_BLOCK_DIM + (local_id_y / muly)|]- (toNumGroups [C.cexp|width|])- (toNumGroups [C.cexp|(height + muly - 1) / muly|])- TransposeLowHeight ->- bigKernel [C.cparams|uint mulx|]- [C.cexp|group_id_x * FUT_BLOCK_DIM * mulx- + local_id_x- + (local_id_y % mulx) * FUT_BLOCK_DIM- |]- [C.cexp|group_id_y * FUT_BLOCK_DIM + (local_id_y / mulx)|]- [C.cexp|group_id_y * FUT_BLOCK_DIM + (local_id_x / mulx)|]- [C.cexp|group_id_x * FUT_BLOCK_DIM * mulx- + local_id_y- + (local_id_x % mulx) * FUT_BLOCK_DIM- |]- (toNumGroups [C.cexp|(width + mulx - 1) / mulx|])- (toNumGroups [C.cexp|height|])- TransposeSmall ->- smallKernel- where- toNumGroups e = [C.cexp|($exp:e + FUT_BLOCK_DIM - 1) / FUT_BLOCK_DIM|]- bigKernel extraparams x_in_index y_in_index x_out_index y_out_index ngrpx ngrpy =- [C.cfun|- // This kernel is optimized to ensure all global reads and writes are coalesced,- // and to avoid bank conflicts in shared memory. The shared memory array is sized- // to (BLOCK_DIM+1)*BLOCK_DIM. This pads each row of the 2D block in shared memory- // so that bank conflicts do not occur when threads address the array column-wise.- //- // Note that input_size/output_size may not equal width*height if we are dealing with- // a truncated array - this happens sometimes for coalescing optimisations.- __kernel void $id:kernel_name($params:params) {- uint num_groups_y = $exp:ngrpy;- uint num_groups_x = $exp:ngrpx;- uint num_groups_z = ((uint)get_num_groups(0)) / (num_groups_y * num_groups_x);-- uint local_id_y = ((uint)get_local_id(0)) / FUT_BLOCK_DIM;- uint local_id_x = ((uint)get_local_id(0)) % FUT_BLOCK_DIM;- uint group_id_z = ((uint)get_group_id(0)) / (num_groups_y * num_groups_x);- uint group_id_yx = ((uint)get_group_id(0)) % (num_groups_y * num_groups_x);- uint group_id_y = group_id_yx / num_groups_x;- uint group_id_x = group_id_yx % num_groups_x;-- uint global_id_z = group_id_z;- uint global_id_y = group_id_y * FUT_BLOCK_DIM + local_id_y;- uint global_id_x = group_id_x * FUT_BLOCK_DIM + local_id_x;-- uint x_index;- uint y_index;- uint our_array_offset;-- // Adjust the input and output arrays with the basic offset.- odata += odata_offset/sizeof($ty:elem_type);- idata += idata_offset/sizeof($ty:elem_type);-- // Adjust the input and output arrays for the third dimension.- our_array_offset = global_id_z * width * height;- odata += our_array_offset;- idata += our_array_offset;-- // read the matrix tile into shared memory- x_index = $exp:x_in_index;- y_index = $exp:y_in_index;-- uint index_in = y_index * width + x_index;-- if(x_index < width && y_index < height && index_in < input_size)- {- block[local_id_y*(FUT_BLOCK_DIM+1)+local_id_x] = idata[index_in];- }-- barrier(CLK_LOCAL_MEM_FENCE);-- // Scatter the transposed matrix tile to global memory.- x_index = $exp:x_out_index;- y_index = $exp:y_out_index;-- uint index_out = y_index * height + x_index;-- if(x_index < height && y_index < width && index_out < output_size)- {- odata[index_out] = block[local_id_x*(FUT_BLOCK_DIM+1)+local_id_y];- }- }|]- where params = [C.cparams|__global $ty:elem_type *odata,- uint odata_offset,- __global $ty:elem_type *idata,- uint idata_offset,- uint width,- uint height,- uint input_size,- uint output_size|] ++ extraparams ++- [C.cparams|__local $ty:elem_type* block|]-- smallKernel =- [C.cfun|- __kernel void $id:kernel_name(__global $ty:elem_type *odata,- uint odata_offset,- __global $ty:elem_type *idata,- uint idata_offset,- uint num_arrays,- uint width,- uint height,- uint input_size,- uint output_size) {- uint our_array_offset = get_global_id(0) / (height*width) * (height*width);- uint x_index = get_global_id(0) % (height*width) / height;- uint y_index = get_global_id(0) % height;-- // Adjust the input and output arrays with the basic offset.- odata += odata_offset/sizeof($ty:elem_type);- idata += idata_offset/sizeof($ty:elem_type);-- // Adjust the input and output arrays.- odata += our_array_offset;- idata += our_array_offset;-- // Read and write the element.- uint index_in = y_index * width + x_index;- uint index_out = x_index * height + y_index;- if (get_global_id(0) < input_size) {- odata[index_out] = idata[index_in];- }-}|]
src/Futhark/Compiler/CLI.hs view
@@ -13,6 +13,7 @@ import Data.Maybe import System.FilePath import System.Console.GetOpt+import System.IO import Futhark.Pipeline import Futhark.Compiler@@ -30,10 +31,12 @@ -> (cfg -> CompilerMode -> FilePath -> Prog lore -> FutharkM ()) -- ^ The action to take on the result of the pipeline. -> IO ()-compilerMain cfg cfg_opts name desc pipeline doIt =+compilerMain cfg cfg_opts name desc pipeline doIt = do+ hSetEncoding stdout utf8+ hSetEncoding stderr utf8 reportingIOErrors $- mainWithOptions (newCompilerConfig cfg) (commandLineOptions ++ map wrapOption cfg_opts)- "options... program" inspectNonOptions+ mainWithOptions (newCompilerConfig cfg) (commandLineOptions ++ map wrapOption cfg_opts)+ "options... program" inspectNonOptions where inspectNonOptions [file] config = Just $ compile config file inspectNonOptions _ _ = Nothing
src/Futhark/Compiler/Program.hs view
@@ -188,4 +188,6 @@ prependRoots roots (E.Prog doc ds) = E.Prog doc $ map mkImport roots ++ ds where mkImport fp =- E.LocalDec (E.OpenDec (E.ModImport fp E.NoInfo noLoc) E.NoInfo noLoc) noLoc+ -- 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
src/Futhark/Doc/Generator.hs view
@@ -275,7 +275,7 @@ ModDec m -> synopsisMod fm m ValDec v -> synopsisValBind v TypeDec t -> synopsisType t- OpenDec x (Info _names) _+ OpenDec x _ | Just opened <- synopsisOpened x -> Just $ do opened' <- opened return $ fullRow $ keyword "open " <> opened'@@ -285,7 +285,8 @@ LocalDec (SigDec s) _ | sigName s `S.member` visible -> synopsisModType (keyword "local" <> " ") s- LocalDec _ _ -> Nothing+ LocalDec{} -> Nothing+ ImportDec{} -> Nothing synopsisOpened :: ModExp -> Maybe (DocM Html) synopsisOpened (ModVar qn _) = Just $ qualNameHtml qn@@ -377,6 +378,9 @@ t' <- typeHtml t return $ keyword "val " <> vnameHtml name <> joinBy " " tps' <> ": " <> t' +prettyEnum :: [Name] -> Html+prettyEnum cs = pipes $ map (("#"<>) . renderName) cs+ typeHtml :: StructType -> DocM Html typeHtml t = case t of Prim et -> return $ primTypeHtml et@@ -404,6 +408,7 @@ parens (vnameHtml v <> ": " <> t1') <> " -> " <> t2' Nothing -> t1' <> " -> " <> t2'+ Enum cs -> return $ prettyEnum cs prettyElem :: ArrayElemTypeBase (DimDecl VName) () -> DocM Html prettyElem (ArrayPrimElem et _) = return $ primTypeHtml et@@ -418,6 +423,7 @@ where ppField (name, tp) = do tp' <- prettyRecordElem tp return $ toHtml (nameToString name) <> ": " <> tp'+prettyElem (ArrayEnumElem cs _ ) = return $ braces $ prettyEnum cs prettyRecordElem :: RecordArrayElemTypeBase (DimDecl VName) () -> DocM Html prettyRecordElem (RecordArrayElem et) = prettyElem et@@ -485,10 +491,10 @@ synopsisSpec spec = case spec of TypeAbbrSpec tpsig -> fullRow <$> typeBindHtml (vnameSynopsisDef $ typeAlias tpsig) tpsig- TypeSpec Unlifted name ps _ _ ->- return $ fullRow $ keyword "type " <> vnameSynopsisDef name <> joinBy " " (map typeParamHtml ps)- TypeSpec Lifted name ps _ _ ->- return $ fullRow $ keyword "type" <> "^" <> vnameSynopsisDef name <> joinBy " " (map typeParamHtml ps)+ TypeSpec l name ps _ _ ->+ return $ fullRow $ keyword l' <> vnameSynopsisDef name <> mconcat (map ((" "<>) . typeParamHtml) ps)+ where l' = case l of Unlifted -> "type "+ Lifted -> "type^ " ValSpec name tparams rettype _ _ -> do let tparams' = map typeParamHtml tparams rettype' <- noLink (map typeParamName tparams) $@@ -529,6 +535,7 @@ parens (vnameHtml v <> ": " <> t1') <> " -> " <> t2' Nothing -> t1' <> " -> " <> t2'+ TEEnum cs _ -> return $ prettyEnum cs qualNameHtml :: QualName VName -> DocM Html qualNameHtml (QualName names vname@(VName name tag)) =@@ -703,6 +710,7 @@ return $ keyword "local module type " <> name' describeDec _ LocalDec{} = Nothing+describeDec _ ImportDec{} = Nothing valBindWhat :: ValBind -> IndexWhat valBindWhat vb =
src/Futhark/Doc/Html.hs view
@@ -8,6 +8,7 @@ , brackets , braces , parens+ , pipes ) where @@ -44,7 +45,11 @@ 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 " | ")
src/Futhark/Internalise.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fmax-pmcheck-iterations=2500000#-} -- | -- -- This module implements a transformation from source to core@@ -17,6 +18,7 @@ import Data.List import Data.Loc import Data.Char (chr)+import Data.Maybe import Language.Futhark as E hiding (TypeArg) import Language.Futhark.Semantic (Imports)@@ -122,7 +124,7 @@ zeroExts ts = generaliseExtTypes ts ts generateEntryPoint :: E.ValBind -> InternaliseM ()-generateEntryPoint (E.ValBind _ ofname retdecl (Info rettype) _ orig_params _ _ loc) =+generateEntryPoint (E.ValBind _ ofname retdecl (Info rettype) _ params _ _ loc) = -- We remove all shape annotations, so there should be no constant -- parameters here. bindingParams [] (map E.patternNoShapeAnnotations params) $@@ -142,14 +144,6 @@ (concat entry_rettype) (shapeparams ++ concat params') entry_body - -- XXX: We massage the parameters a little bit to handle the case- -- where there is just a single parameter that is a tuple. This is- -- wide-spread in existing Futhark code, although I'd like to get- -- rid of it.- where params = case orig_params of- [TuplePattern ps _] -> ps- _ -> orig_params- entryPoint :: [(E.Pattern,[I.FParam])] -> (Maybe (E.TypeExp VName), E.StructType, [[I.TypeBase ExtShape Uniqueness]]) -> EntryPoint@@ -182,9 +176,27 @@ [I.TypeDirect] entryPointType (te, t, ts) = [I.TypeOpaque desc $ length ts]- where desc = maybe (pretty t') pretty te+ where desc = maybe (pretty t') typeExpOpaqueName te t' = removeShapeAnnotations t `E.setUniqueness` Nonunique + -- | We remove dimension arguments such that we hopefully end+ -- up with a simpler type name for the entry point. The+ -- intend is that if an entry point uses a type 'nasty [w] [h]',+ -- then we should turn that into an opaque type just called+ -- 'nasty'. Also, we try to give arrays of opaques a nicer name.+ typeExpOpaqueName (TEApply te TypeArgExpDim{} _) =+ typeExpOpaqueName te+ typeExpOpaqueName (TEArray te _ _) =+ let (d, te') = withoutDims te+ in "arr_" ++ typeExpOpaqueName te' +++ "_" ++ show (1 + d) ++ "d"+ typeExpOpaqueName te = pretty te++ withoutDims (TEArray te _ _) =+ let (d, te') = withoutDims te+ in (d+1, te')+ withoutDims te = (0::Int, te)+ internaliseIdent :: E.Ident -> InternaliseM I.VName internaliseIdent (E.Ident name (Info tp) loc) = case tp of@@ -421,15 +433,8 @@ args' <- concat <$> mapM (internaliseExp "arg") args fst <$> funcall desc qfname args' loc -internaliseExp desc (E.LetPat tparams pat e body loc) = do- ses <- internaliseExp desc e- t <- I.staticShapes <$> mapM I.subExpType ses- stmPattern tparams pat t $ \cm pat_names match -> do- mapM_ (uncurry (internaliseDimConstant loc)) cm- ses' <- match loc ses- forM_ (zip pat_names ses') $ \(v,se) ->- letBindNames_ [v] $ I.BasicOp $ I.SubExp se- internaliseExp desc body+internaliseExp desc (E.LetPat tparams pat e body loc) =+ internalisePat desc tparams pat e body loc (internaliseExp desc) internaliseExp desc (E.LetFun ofname (tparams, params, retdecl, Info rettype, body) letbody loc) = do internaliseValBind $ E.ValBind False ofname retdecl (Info rettype) tparams params body Nothing loc@@ -578,47 +583,27 @@ init_loop_cond_bnds)) internaliseExp desc (E.LetWith name src idxs ve body loc) = do- srcs <- internaliseExpToVars "src" $- E.Var (qualName (E.identName src)) (vacuousShapeAnnotations <$> E.identType src)- (srclocOf src)+ let pat = E.Id (E.identName name) (E.vacuousShapeAnnotations <$> E.identType name) loc+ src_t = E.fromStruct . E.vacuousShapeAnnotations <$> E.identType src+ e = E.Update (E.Var (E.qualName $ E.identName src) src_t loc) idxs ve loc+ internaliseExp desc $ E.LetPat [] pat e body loc++internaliseExp desc (E.Update src slice ve loc) = do ves <- internaliseExp "lw_val" ve+ srcs <- internaliseExpToVars "src" src dims <- case srcs of [] -> return [] -- Will this happen? v:_ -> I.arrayDims <$> lookupType v- (idxs', cs) <- internaliseSlice loc dims idxs+ (idxs', cs) <- internaliseSlice loc dims slice+ let comb sname ve' = do sname_t <- lookupType sname- let slice = fullSlice sname_t idxs'- rowtype = sname_t `setArrayDims` sliceDims slice+ let full_slice = fullSlice sname_t idxs'+ rowtype = sname_t `setArrayDims` sliceDims full_slice ve'' <- ensureShape asserting "shape of value does not match shape of source array" loc rowtype "lw_val_correct_shape" ve'- certifying cs $- letInPlace "letwith_dst" sname (fullSlice sname_t idxs') $ BasicOp $ SubExp ve''- dsts <- zipWithM comb srcs ves- dstt <- I.staticShapes <$> mapM lookupType dsts- let pat = E.Id (E.identName name)- (E.vacuousShapeAnnotations <$> E.identType name)- (srclocOf name)- stmPattern [] pat dstt $ \cm pat_names match -> do- mapM_ (uncurry (internaliseDimConstant loc)) cm- dsts' <- match loc $ map I.Var dsts- forM_ (zip pat_names dsts') $ \(v,dst) ->- letBindNames_ [v] $ I.BasicOp $ I.SubExp dst- internaliseExp desc body--internaliseExp desc (E.Update src slice ve loc) = do- src_name <- newVName "update_src"- dest_name <- newVName "update_dest"- let src_t = E.typeOf src- src_ident = E.Ident src_name (E.Info src_t) loc- dest_ident = E.Ident dest_name (E.Info src_t) loc-- internaliseExp desc $- E.LetPat [] (E.Id src_name (E.Info $ E.vacuousShapeAnnotations src_t) loc) src- (E.LetWith dest_ident src_ident slice ve- (E.Var (E.qualName dest_name) (E.Info (E.vacuousShapeAnnotations src_t)) loc)- loc)- loc+ letInPlace desc sname full_slice $ BasicOp $ SubExp ve''+ certifying cs $ map I.Var <$> zipWithM comb srcs ves internaliseExp desc (E.RecordUpdate src fields ve _ _) = do src' <- internaliseExp desc src@@ -816,6 +801,28 @@ w <- arraysSize 0 <$> mapM lookupType arrs letTupExp' desc $ I.Op $ I.Stream w form lam' arrs +internaliseExp _ (E.VConstr0 c (Info t) loc) =+ case t of+ Enum cs ->+ case elemIndex c $ sort cs of+ Just i -> return [I.Constant $ I.IntValue $ intValue I.Int8 i]+ _ -> fail $ "internaliseExp: invalid constructor: #" ++ nameToString c +++ "\nfor enum at " ++ locStr loc ++ ": " ++ pretty t+ _ -> fail $ "internaliseExp: nonsensical type for enum at "+ ++ locStr loc ++ ": " ++ pretty t++internaliseExp desc (E.Match e cs _ loc) =+ case cs of+ [CasePat _ eCase _] -> internaliseExp desc eCase+ (c:cs') -> do+ bFalse <- bFalseM+ letTupExp' desc =<< generateCaseIf desc e c bFalse+ where bFalseM = do+ eLast' <- internalisePat desc [] pLast e eLast locLast internaliseBody+ foldM (\bf c' -> eBody $ return $ generateCaseIf desc e c' bf) eLast' (reverse $ init cs')+ CasePat pLast eLast locLast = last cs'+ [] -> fail $ "internaliseExp: match with no cases at: " ++ locStr loc+ -- The "interesting" cases are over, now it's mostly boilerplate. internaliseExp _ (E.Literal v _) =@@ -880,6 +887,61 @@ internaliseExp _ e@E.IndexSection{} = fail $ "internaliseExp: Unexpected index section at " ++ locStr (srclocOf e) +andExp :: E.Exp -> E.Exp -> E.Exp+andExp l r = E.If l r (E.Literal (E.BoolValue False) noLoc) (Info (E.Prim E.Bool)) noLoc++eqExp :: E.Exp -> E.Exp -> E.Exp+eqExp l r = E.BinOp eq (Info $ vacuousShapeAnnotations ft)+ (l, sType l) (r, sType r) (Info (E.Prim E.Bool)) noLoc+ where sType e = Info $ toStruct $ vacuousShapeAnnotations $ E.typeOf e+ arrow = Arrow S.empty Nothing+ ft = E.typeOf l `arrow` E.typeOf r `arrow` E.Prim E.Bool+ eq = qualName $ VName "==" (-1)++generateCond :: E.Pattern -> E.Exp -> E.Exp+generateCond p e = foldr andExp (E.Literal (E.BoolValue True) noLoc) conds+ where conds = mapMaybe ((<*> pure e) . fst) $ generateCond' p++ generateCond' :: E.Pattern -> [(Maybe (E.Exp -> E.Exp), CompType)]+ generateCond' (E.TuplePattern ps loc) = generateCond' (E.RecordPattern fs loc)+ where fs = zipWith (\i p' -> (nameFromString (show i), p')) ([1..] :: [Integer]) ps+ generateCond' (E.RecordPattern fs _) = concatMap instCond holes+ where holes = map (\(n, p') -> (generateCond' p', n)) fs+ field ([],_) = Nothing+ field ((_, t):_, f) = Just (f, t)+ t' = Record $ M.fromList $ mapMaybe field holes+ projectHole _ (Nothing, _) = (Nothing, t')+ projectHole f (Just condHole, t) =+ (Just (\e' -> condHole $ Project f e' (Info t) noLoc), t')+ instCond (condHoles, f) = map (projectHole f) condHoles+ generateCond' (E.PatternParens p' _) = generateCond' p'+ generateCond' (E.Id _ (Info t) _) =+ [(Nothing, removeShapeAnnotations t)]+ generateCond' (E.Wildcard (Info t) _)=+ [(Nothing, removeShapeAnnotations t)]+ generateCond' (E.PatternAscription p' _ _) = generateCond' p'+ generateCond' (E.PatternLit ePat (Info t) _) =+ [(Just (eqExp ePat), removeShapeAnnotations t)]+++generateCaseIf :: String -> E.Exp -> Case -> I.Body -> InternaliseM I.Exp+generateCaseIf desc e (CasePat p eCase loc) bFail = do+ eCase' <- internalisePat desc [] p e eCase loc internaliseBody+ eIf cond (return eCase') (return bFail)+ where cond = BasicOp . SubExp <$> internaliseExp1 "cond" (generateCond p e)++internalisePat :: String -> [TypeParamBase VName] -> E.Pattern -> E.Exp+ -> E.Exp -> SrcLoc -> (E.Exp -> InternaliseM a) -> InternaliseM a+internalisePat desc tparams p e body loc m = do+ ses <- internaliseExp desc e+ t <- I.staticShapes <$> mapM I.subExpType ses+ stmPattern tparams p t $ \cm pat_names match -> do+ mapM_ (uncurry (internaliseDimConstant loc)) cm+ ses' <- match loc ses+ forM_ (zip pat_names ses') $ \(v,se) ->+ letBindNames_ [v] $ I.BasicOp $ I.SubExp se+ m body+ internaliseSlice :: SrcLoc -> [SubExp] -> [E.DimIndex]@@ -1689,6 +1751,8 @@ arg' <- case arg of TypeArgExpType argt -> typeExpForError cm argt TypeArgExpDim d _ -> pure <$> dimDeclForError cm d return $ t' ++ [" "] ++ arg'+typeExpForError _ e@E.TEEnum{} =+ return [ErrorString $ pretty e] dimDeclForError :: ConstParams -> E.DimDecl VName -> InternaliseM (ErrorMsgPart SubExp) dimDeclForError cm (NamedDim d) = do
src/Futhark/Internalise/Bindings.hs view
@@ -140,6 +140,8 @@ flattenPattern' $ E.TuplePattern (map snd $ sortFields $ M.fromList fs) loc flattenPattern' (E.PatternAscription p _ _) = flattenPattern' p+ flattenPattern' (E.PatternLit _ t loc) =+ flattenPattern' $ E.Wildcard t loc type MatchPattern = SrcLoc -> [I.SubExp] -> InternaliseM [I.SubExp]
src/Futhark/Internalise/Defunctionalise.hs view
@@ -310,13 +310,15 @@ (e2', sv2) <- defuncExp e2 let sv = staticField sv1 sv2 fs return (RecordUpdate e1' fs e2'- (Info $ vacuousShapeAnnotations $ typeFromSV sv) loc,+ (Info $ vacuousShapeAnnotations $ typeFromSV sv1) loc, sv) where staticField (RecordSV svs) sv2 (f:fs') = case lookup f svs of Just sv -> RecordSV $ (f, staticField sv sv2 fs') : filter ((/=f) . fst) svs Nothing -> error "Invalid record projection."+ staticField (Dynamic t@Record{}) sv2 fs'@(_:_) =+ staticField (svFromType t) sv2 fs' staticField _ sv2 _ = sv2 defuncExp e@(Map fun arr t loc) = do@@ -379,10 +381,28 @@ (e2', sv) <- defuncExp e2 return (Assert e1' e2' desc loc, sv) +defuncExp e@VConstr0{} = return (e, Dynamic $ typeOf e)++defuncExp (Match e cs t loc) = do+ (e', sv) <- defuncExp e+ csPairs <- mapM (defuncCase sv) cs+ let cs' = map fst csPairs+ sv' = case csPairs of+ [] -> error "Matches must always have at least one case."+ c':_ -> snd c'+ return (Match e' cs' t loc, sv')+ -- | Same as 'defuncExp', except it ignores the static value. defuncExp' :: Exp -> DefM Exp defuncExp' = fmap fst . defuncExp +defuncCase :: StaticVal -> Case -> DefM (Case, StaticVal)+defuncCase sv (CasePat p e loc) = do+ let p' = updatePattern p sv+ env = matchPatternSV p sv+ (e', sv') <- localEnv env $ defuncExp e+ return (CasePat p' e' loc, sv')+ -- | Defunctionalize the function argument to a SOAC by eta-expanding if -- necessary and then defunctionalizing the body of the introduced lambda. defuncSoacExp :: Exp -> DefM Exp@@ -604,6 +624,7 @@ Id vn (Info t) _ -> M.singleton vn $ Dynamic $ removeShapeAnnotations t Wildcard _ _ -> mempty PatternAscription p _ _ -> envFromPattern p+ PatternLit{} -> mempty -- | Create an environment that binds the shape parameters. envFromShapeParams :: [TypeParamBase VName] -> Env@@ -702,6 +723,7 @@ else M.singleton vn sv matchPatternSV (Wildcard _ _) _ = mempty matchPatternSV (PatternAscription pat _ _) sv = matchPatternSV pat sv+matchPatternSV PatternLit{} _ = mempty matchPatternSV pat (Dynamic t) = matchPatternSV pat $ svFromType t matchPatternSV pat sv = error $ "Tried to match pattern " ++ pretty pat ++ " with static value " ++ show sv ++ "."@@ -733,6 +755,7 @@ | orderZero . unInfo $ expandedType tydecl = PatternAscription (updatePattern pat sv) tydecl loc | otherwise = updatePattern pat sv+updatePattern p@PatternLit{} _ = p updatePattern pat (Dynamic t) = updatePattern pat (svFromType t) updatePattern pat sv = error $ "Tried to update pattern " ++ pretty pat@@ -842,6 +865,10 @@ Unzip e _ _ -> freeVars e Unsafe e _ -> freeVars e Assert e1 e2 _ _ -> freeVars e1 <> freeVars e2+ VConstr0{} -> mempty+ Match e cs _ _ -> freeVars e <> foldMap caseFV cs+ where caseFV (CasePat p eCase _) = (names (patternDimNames p) <> freeVars eCase)+ `without` patternVars p freeDimIndex :: DimIndexBase Info VName -> NameSet freeDimIndex (DimFix e) = freeVars e
src/Futhark/Internalise/Defunctorise.hs view
@@ -273,9 +273,12 @@ bindingNames [modName mb] $ do mod_scope <- transformModBind mb extendScope mod_scope $ mappend <$> transformDecs ds' <*> pure mod_scope- OpenDec e _ _ : ds' -> do+ OpenDec e _ : ds' -> do scope <- modScope <$> evalModExp e extendScope scope $ mappend <$> transformDecs ds' <*> pure scope+ ImportDec name name' loc : ds' ->+ let d = LocalDec (OpenDec (ModImport name name' loc) loc) loc+ in transformDecs $ d : ds' transformImports :: Imports -> TransformM () transformImports [] = return ()
src/Futhark/Internalise/Monomorphise.hs view
@@ -374,6 +374,15 @@ transformExp (Assert e1 e2 desc loc) = Assert <$> transformExp e1 <*> transformExp e2 <*> pure desc <*> pure loc +transformExp e@VConstr0{} = return e+transformExp (Match e cs t loc) =+ Match <$> transformExp e <*> mapM transformCase cs <*> pure t <*> pure loc++transformCase :: Case -> MonoM Case+transformCase (CasePat p e loc) = do+ (p', rr) <- expandRecordPattern p+ CasePat <$> pure p' <*> withRecordReplacements rr (transformExp e) <*> pure loc+ transformDimIndex :: DimIndexBase Info VName -> MonoM (DimIndexBase Info VName) transformDimIndex (DimFix e) = DimFix <$> transformExp e transformDimIndex (DimSlice me1 me2 me3) =@@ -454,6 +463,7 @@ expandRecordPattern (PatternAscription pat td loc) = do (pat', rr) <- expandRecordPattern pat return (PatternAscription pat' td loc, rr)+expandRecordPattern (PatternLit e t loc) = return (PatternLit e t loc, mempty) -- | Monomorphize a polymorphic function at the types given in the instance -- list. Monomorphizes the body of the function as well. Returns the fresh name@@ -464,7 +474,7 @@ t' <- removeTypeVariablesInType t let bind_t = foldFunType (map (toStructural . patternType) params) $ toStructural rettype- substs = typeSubsts bind_t t'+ substs = M.map Subst $ typeSubsts bind_t t' rettype' = applySubst (`M.lookup` substs) rettype params' = map (substPattern $ applySubst (`M.lookup` substs)) params @@ -515,18 +525,20 @@ | Just t1' <- peelArray (arrayRank t1) t1, Just t2' <- peelArray (arrayRank t1) t2 = typeSubsts t1' t2'+typeSubsts Enum{} Enum{} = mempty typeSubsts t1 t2 = error $ unlines ["typeSubsts: mismatched types:", pretty t1, pretty t2] -- | Perform a given substitution on the types in a pattern. substPattern :: (PatternType -> PatternType) -> Pattern -> Pattern substPattern f pat = case pat of- TuplePattern pats loc -> TuplePattern (map (substPattern f) pats) loc- RecordPattern fs loc -> RecordPattern (map substField fs) loc+ TuplePattern pats loc -> TuplePattern (map (substPattern f) pats) loc+ RecordPattern fs loc -> RecordPattern (map substField fs) loc where substField (n, p) = (n, substPattern f p)- PatternParens p loc -> PatternParens (substPattern f p) loc- Id vn (Info tp) loc -> Id vn (Info $ f tp) loc- Wildcard (Info tp) loc -> Wildcard (Info $ f tp) loc- PatternAscription p td loc -> PatternAscription (substPattern f p) td loc+ PatternParens p loc -> PatternParens (substPattern f p) loc+ Id vn (Info tp) loc -> Id vn (Info $ f tp) loc+ Wildcard (Info tp) loc -> Wildcard (Info $ f tp) loc+ PatternAscription p td loc -> PatternAscription (substPattern f p) td loc+ PatternLit e (Info tp) loc -> PatternLit e (Info $ f tp) loc toPolyBinding :: ValBind -> PolyBinding toPolyBinding (ValBind _ name retdecl (Info rettype) tparams params body _ loc) =
src/Futhark/Internalise/TypesValues.hs view
@@ -119,6 +119,7 @@ ets <- internaliseElemType et return [I.arrayOf et' (Shape dims) $ internaliseUniqueness u | et' <- ets ] E.Arrow{} -> fail $ "internaliseTypeM: cannot handle function type: " ++ pretty orig_t+ E.Enum{} -> return [I.Prim $ I.IntType I.Int8] where internaliseElemType E.ArrayPolyElem{} = fail "internaliseElemType: cannot handle type variable."@@ -126,6 +127,8 @@ return [I.Prim $ internalisePrimType bt] internaliseElemType (E.ArrayRecordElem elemts) = concat <$> mapM (internaliseRecordElem . snd) (E.sortFields elemts)+ internaliseElemType (E.ArrayEnumElem _ _) =+ return [I.Prim $ I.IntType I.Int8] internaliseRecordElem (E.RecordArrayElem et) = internaliseElemType et
src/Futhark/Optimise/MemoryBlockMerging/Liveness/FirstUse.hs view
@@ -175,7 +175,6 @@ createsNewArrayBase :: Exp lore -> Bool createsNewArrayBase e = case e of- BasicOp Partition{} -> True BasicOp Replicate{} -> True BasicOp Iota{} -> True BasicOp Manifest{} -> True
src/Futhark/Optimise/Simplify/Engine.hs view
@@ -40,7 +40,6 @@ , isOp , isNotSafe , asksEngineEnv- , changed , askVtable , localVtable @@ -167,8 +166,7 @@ let (x, (src', b), _) = runRWS m (simpl, env) (src, False) in ((x, b), src') -subSimpleM :: (MonadFreshNames m,- SameScope outerlore lore,+subSimpleM :: (SameScope outerlore lore, ExpAttr outerlore ~ ExpAttr lore, BodyAttr outerlore ~ BodyAttr lore, RetType outerlore ~ RetType lore,@@ -177,14 +175,15 @@ -> Env lore -> ST.SymbolTable (Wise outerlore) -> SimpleM lore a- -> m (a, Bool)+ -> SimpleM outerlore a subSimpleM simpl env outer_vtable m = do let inner_vtable = ST.castSymbolTable outer_vtable src <- getNameSource let SimpleM m' = localVtable (<>inner_vtable) m (x, (src', b), _) = runRWS m' (simpl, env) (src, False) putNameSource src'- return (x, b)+ when b changed+ return x askEngineEnv :: SimpleM lore (Env lore) askEngineEnv = snd <$> ask@@ -680,7 +679,7 @@ protectLoopHoisted ctx' val' (WhileLoop cond')) seq_blocker <- asksEngineEnv $ blockHoistSeq . envHoistBlockers ((loopstms, loopres), hoisted) <-- enterLoop $+ enterLoop $ consumeMerge $ bindFParams (ctxparams'++valparams') $ wrapbody $ blockIf (hasFree boundnames `orIf` isConsumed@@ -689,7 +688,12 @@ return ((res, uses <> isDoLoopResult res), stms) loopbody' <- constructBody loopstms loopres return (DoLoop ctx' val' form' loopbody', hoisted)- where fparamnames = S.fromList (map (paramName . fst) $ ctx++val)+ where fparamnames =+ S.fromList (map (paramName . fst) $ ctx++val)+ consumeMerge =+ localVtable $ flip (foldl' (flip ST.consume)) consumed_by_merge+ consumed_by_merge =+ freeIn $ map snd $ filter (unique . paramDeclType . fst) val simplifyExp (Op op) = do (op', stms) <- simplifyOp op return (Op op', stms)
src/Futhark/Optimise/Simplify/Rules.hs view
@@ -355,8 +355,8 @@ -- This simplistic rule is only valid before we introduce memory. removeUnnecessaryCopy :: BinderOps lore => BottomUpRuleBasicOp lore removeUnnecessaryCopy (vtable,used) (Pattern [] [d]) _ (Copy v)- | not (v `UT.used` used),- consumable || not (patElemName d `UT.isConsumed` used) =+ | not (v `UT.isConsumed` used),+ (not (v `UT.used` used) && consumable) || not (patElemName d `UT.isConsumed` used) = letBind_ (Pattern [] [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,@@ -686,7 +686,7 @@ Just (Copy src, cs) | Just dims <- arrayDims <$> seType (Var src), length inds == length dims,- not consuming ->+ not consuming, ST.available src vtable -> Just $ pure $ IndexResult cs src inds Just (Reshape newshape src, cs)@@ -1197,6 +1197,25 @@ certifying (cs<>v_cs) $ letBind_ pat $ BasicOp $ Rotate offsets v2 where add x y = letSubExp "offset" $ BasicOp $ BinOp (Add Int32) x y++-- If we see an Update with a scalar where the value to be written is+-- the result of indexing some other array, then we convert it into an+-- 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))+ | Just _ <- sliceIndices slice_x,+ Just (Index arr_y slice_y, cs_y) <- ST.lookupBasicOp v vtable,+ ST.available arr_y vtable,+ -- XXX: we should check for proper aliasing here instead.+ arr_y /= arr_x,+ Just (slice_x_bef, DimFix i, []) <- focusNth (length slice_x - 1) slice_x,+ Just (slice_y_bef, DimFix j, []) <- focusNth (length slice_y - 1) slice_y = do+ 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' ruleBasicOp _ _ _ _ = cannotSimplify
src/Futhark/Optimise/TileLoops.hs view
@@ -21,6 +21,7 @@ import Futhark.Pass import Futhark.Tools import Futhark.Util (mapAccumLM)+import Futhark.Optimise.TileLoops.RegTiling3D tileLoops :: Pass Kernels Kernels tileLoops = Pass "tile loops" "Tile stream loops inside kernels" $@@ -36,19 +37,23 @@ type TileM = ReaderT (Scope Kernels) (State VNameSource) optimiseBody :: Body Kernels -> TileM (Body Kernels)-optimiseBody (Body () bnds res) =+optimiseBody (Body () bnds res) = localScope (scopeOf bnds) $ Body () <$> (mconcat <$> mapM optimiseStm (stmsToList bnds)) <*> pure res optimiseStm :: Stm Kernels -> TileM (Stms Kernels)-optimiseStm (Let pat aux (Op old_kernel@(Kernel desc space ts body))) = do- (extra_bnds, space', body') <- tileInKernelBody mempty initial_variance space body- let new_kernel = Kernel desc space' ts body'- -- XXX: we should not change the type of the kernel (such as by- -- changing the number of groups being used for a kernel that- -- returns a result-per-group).- if kernelType old_kernel == kernelType new_kernel- then return $ extra_bnds <> oneStm (Let pat aux $ Op new_kernel)- else return $ oneStm $ Let pat aux $ Op old_kernel+optimiseStm stmt@(Let pat aux (Op old_kernel@(Kernel desc space ts body))) = do+ res3dtiling <- doRegTiling3D stmt+ case res3dtiling of+ Just (extra_bnds, stmt') -> return $ extra_bnds <> oneStm stmt'+ Nothing -> do+ (extra_bnds, space', body') <- tileInKernelBody mempty initial_variance space body+ let new_kernel = Kernel desc space' ts body'+ -- XXX: we should not change the type of the kernel (such as by+ -- changing the number of groups being used for a kernel that+ -- returns a result-per-group).+ if kernelType old_kernel == kernelType new_kernel+ then return $ extra_bnds <> oneStm (Let pat aux $ Op new_kernel)+ else return $ oneStm $ Let pat aux $ Op old_kernel where initial_variance = M.map mempty $ scopeOfKernelSpace space optimiseStm (Let pat aux e) = pure <$> (Let pat aux <$> mapExpM optimise e)
+ src/Futhark/Optimise/TileLoops/RegTiling3D.hs view
@@ -0,0 +1,739 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+-- | Perform a restricted form of register tiling corresponding to+-- the following pattern:+-- * a stream is perfectly nested inside a kernel with at least+-- three parallel dimension (the perfectly nested restriction+-- can be relaxed a bit);+-- * all streamed arrays are one dimensional;+-- * all streamed arrays are variant to exacly one of the three+-- innermost parallel dimensions, and conversly for each of+-- the three innermost parallel dimensions, there is at least+-- one streamed array variant to it;+-- * the stream's result is a tuple of scalar values, which are+-- also the "thread-in-space" return of the kernel.+-- Target code can be found in "tests/reg-tiling/reg-tiling-3d.fut".+module Futhark.Optimise.TileLoops.RegTiling3D+ ( doRegTiling3D )+ where++import Control.Monad.State+import Control.Monad.Reader+import qualified Data.Set as S+import qualified Data.Map.Strict as M+import Data.List+import Data.Semigroup ((<>))+import Data.Maybe++import Futhark.MonadFreshNames+import Futhark.Representation.Kernels+import Futhark.Tools+import Futhark.Transform.Substitute+import Futhark.Transform.Rename++type TileM = ReaderT (Scope Kernels) (State VNameSource)+type VarianceTable = M.Map VName Names++maxRegTile :: Int32+maxRegTile = 30++mkRegTileSe :: Int32 -> SubExp+mkRegTileSe = constant++-- | Expects a kernel statement as argument.+-- CONDITIONS for 3D tiling optimization to fire are:+-- 1. a) The kernel body can be broken into+-- scalar-code-1 ++ [GroupStream stmt] ++ scalar-code-2.+-- b) The kernels has a "ThreadsReturn ThreadsInSpace" result,+-- and obviously the result is variant to the 3rd dimension+-- (counter from innermost to outermost)+-- 2. For the GroupStream (morally StreamSeq):+-- a) the arrays' outersize must equal the maximal chunk size+-- b) the streamed arrays are one dimensional+-- c) each of the array arguments of GroupStream are variant+-- to exactly one of the three innermost-parallel dimension+-- of the kernel. This condition can be relaxed by interchanging+-- kernel dimensions whenever possible.+-- 3. For scalar-code-1:+-- a) each of the statements is a slice that produces one of the+-- streamed arrays+-- 4. For simplicity assume scalar-code-2 is empty!+-- (To be extended later.)+-- ASSUME the initial kernel is (as in tests/reg-tiling/reg-tiling-3d.fut):+--+-- kernel map(num groups: num_groups, group size: group_size,+-- num threads: num_threads, global TID -> global_tid,+-- local TID -> local_tid, group ID -> group_id)+-- (gtid_z < size_z, gtid_y < size_xy,+-- gtid_x < size_xy) : {f32} {+-- let {[size_com]f32 flags} = <empty_or_match_cert_6685>fss_6664[gtid_z,+-- 0i32:+size_com*1i32]+-- let {[size_com]f32 ass} = ass_6662[gtid_y, 0i32:+size_com*1i32]+-- let {[size_com]f32 bss} = res_6687[gtid_x, 0i32:+size_com*1i32]+-- let {f32 res_ker} =+-- stream(size_com, size_com,+-- fn (int chunk_size_out, int chunk_offset_6736, f32 acc_out,+-- [chunk_size_out]f32 flags_chunk_out,+-- [chunk_size_out]f32 ass_chunk_out,+-- [chunk_size_out]f32 bss_chunk_out) =>+-- let {f32 res_out} =+-- stream(chunk_size_out, 1i32,+-- fn (int chunk_size_in, int i_6743, f32 acc_in,+-- [chunk_size_in]f32 flags_chunk_in,+-- [chunk_size_in]f32 ass_chunk_in,+-- [chunk_size_in]f32 bss_chunk_in) =>+-- let {f32 f} = flags_chunk_in[0i32]+-- let {f32 a} = ass_chunk_in[0i32]+-- let {f32 b} = bss_chunk_in[0i32]+-- let {bool cond} = lt32(f, 9.0f32)+-- let {f32 tmp} =+-- if cond+-- then {+-- let {f32 tmp1} = fmul32(a, b)+-- in {tmp1}+-- } else {0.0f32}+-- let {f32 res_in} = fadd32(acc_in, tmp)+-- in {res_in},+-- {acc_out},+-- flags_chunk_out, ass_chunk_out, bss_chunk_out)+-- in {res_out},+-- {0.0f32},+-- flags, ass, bss)+-- return {thread in space returns res_ker}+-- }+--+doRegTiling3D :: Stm Kernels -> TileM (Maybe (Stms Kernels, Stm Kernels))+doRegTiling3D (Let pat aux (Op old_kernel))+ | Kernel kerhint space kertp (KernelBody () kstms kres) <- old_kernel,+ FlatThreadSpace gspace <- spaceStructure space,+ initial_variance <- M.map mempty $ scopeOfKernelSpace space,+ variance <- varianceInStms initial_variance kstms,+ local_tid <- spaceLocalId space,+ (_,_) : (_,_) : (gidz,m_M) : _ <- reverse $ spaceDimensions space,+ (code1, Just stream_stmt, code2) <- matchCodeStreamCode kstms,+ Let pat_strm aux_strm (Op (GroupStream w w0 lam accs arrs)) <- stream_stmt,+ not (null accs),+ reg_tile <- maxRegTile `quot` fromIntegral (length accs),+ reg_tile_se <- mkRegTileSe reg_tile,+ w == w0,+ arr_chunk_params <- groupStreamArrParams lam,+ Just _ <- is3dTileable mempty space variance+ arrs arr_chunk_params,+ Just arr_tab0 <- foldl (processIndirections $ S.fromList arrs)+ (Just M.empty) code1,+ -- for simplicity, assume a single result, which is variant to+ -- the outer parallel dimension (for sanity sake, it should be)+ ker_res_nms <- mapMaybe retThreadInSpace kres,+ length ker_res_nms == length kres,+ Pattern [] ker_patels <- pat,+ all primType kertp,+ all (variantToOuterDim variance gidz) ker_res_nms = do+ mm <- newVName "mm"+ mask <- newVName "mask"++ -- let mm = gidz * regTile+ let mm_stmt = mkInKerIntMulStmt mm (Var gidz) reg_tile_se+ let mask_stm= mkLet [] [Ident mask $ Prim int32] $ BasicOp $+ BinOp (Shl Int32)+ (Constant $ IntValue $ Int32Value 1 )+ (Constant $ IntValue $ Int32Value 31)++ -- process the z-variant arrays that need transposition;+ -- these "manifest" statements should come before the kernel+ (arr_tab,trnsp_tab) <- foldM (insertTranspose variance gidz)+ (M.empty, M.empty) $ M.toList arr_tab0+ let manif_stms = map(\ (a_t, (a,i,tp)) ->+ let perm = [i+1..arrayRank tp-1] ++ [0..i]+ in mkLet [] [Ident a_t tp] $+ BasicOp $ Manifest perm a+ ) $ M.toList trnsp_tab++ -- adjust the kernel space for 3d register tiling.+ (space_stms, space_struct, tiled_group_size, num_threads, num_groups) <-+ mkKerSpaceExtraStms reg_tile gspace+ let kspace' = space { spaceStructure = space_struct+ , spaceGroupSize = tiled_group_size+ , spaceNumThreads = num_threads+ , spaceNumGroups = num_groups+ }++ -- most everything happans here!+ mb_myloop <- translateStreamsToLoop (reg_tile,mask,gidz,m_M,mm,local_tid,tiled_group_size)+ variance arr_tab w lam accs arrs $+ patternValueElements pat_strm++ -- ToDo: adjust the new kernel with+ -- 1. in-place update return: for this you will need to `scratch`+ -- the result array before the kernel+ -- 2. adjust the range of gidz to `(m_M + TILE_REG -1)/ TILE_REG`+ -- 3. transpose the array invariant to the third-inner dim+ case mb_myloop of+ Nothing -> return Nothing+ Just (myloop, strm_res_inv, strm_res_var) -> do+ -- make loop statement+ loop_var_res <- forM strm_res_var $ \(PatElem nm attr) -> do+ clone_patel_nms <- replicateM (fromIntegral reg_tile) $ newVName $ baseString nm+ return $ map (`PatElem` attr) clone_patel_nms+ let pat_loop = Pattern [] $ strm_res_inv ++ concat loop_var_res+ let stm_loop = Let pat_loop aux_strm myloop++ -- get variant ker-results and corresponding pattern elements+ let ker_var_res_patels =+ filter (\(r,_) -> variantToOuterDim variance gidz r) $+ zip ker_res_nms ker_patels+ (ker_var_res, ker_var_patels) = unzip ker_var_res_patels+ (code2_var, code2_inv) =+ partition (variantToOuterDim variance gidz . patElemName .+ head . patternValueElements . stmPattern) code2++ -- make the scratch statements for kernel results variant to the z-parallel dimension+ scratch_nms_stms <- mapM mkScratchStm ker_var_patels+ let (scratch_nms, scratch_stms) = unzip scratch_nms_stms+ loop_var_nms_tr = transpose $ map (map patElemName) loop_var_res++ -- clone the statements in code2 variant to the z-parallel dimension,+ -- by encapsulating them inside if-then-else in which the then-body+ -- terminates with an in-place update corresponding to the result!+ strm_var_nms = map patElemName strm_res_var+ (ip_out_nms, unrolled_code) <-+ foldM (cloneVarCode2 mm space strm_var_nms ker_var_res_patels code2_var)+ (scratch_nms, []) $ zip [0..reg_tile-1] loop_var_nms_tr++ -- replace the `ThreadsInSpace` kernel return to an `InPlace` return+ -- for the z-variant kernel results+ let ker_res_ip_tp_tab = M.fromList $ zip ker_var_res $ zip ip_out_nms $+ map patElemType ker_var_patels+ (kres', kertp') = unzip $+ zipWith (\ r tp -> case M.lookup r ker_res_ip_tp_tab of+ Nothing -> (ThreadsReturn ThreadsInSpace (Var r), tp)+ Just (ip_nm, ip_tp) -> (KernelInPlaceReturn ip_nm, ip_tp)+ ) ker_res_nms kertp++ -- finally, put everything together+ kstms' = stmsFromList $ mask_stm : mm_stmt : stm_loop : (code2_inv ++ unrolled_code)+ ker_body = KernelBody () kstms' kres'+ new_ker = Op $ Kernel kerhint kspace' kertp' ker_body+ extra_stms = space_stms <> stmsFromList (scratch_stms ++ manif_stms)+ return $ Just (extra_stms, Let pat aux new_ker)++ where -- | Checks that the statement is a slice that produces one of the+ -- streamed arrays. Also that the streamed array is one dimensional.+ -- Accumulates the information in a table for later use.+ processIndirections :: S.Set VName+ -> Maybe (M.Map VName (VName, Slice SubExp, Type))+ -> Stm InKernel+ -> Maybe (M.Map VName (VName, Slice SubExp, Type))+ processIndirections arrs acc (Let patt _ (BasicOp (Index arr_nm slc))) =+ case (acc, patternValueElements patt) of+ (Nothing, _) -> Nothing+ (Just tab, [p]) -> do+ let (p_nm, p_tp) = (patElemName p, patElemType p)+ case (S.member p_nm arrs, p_tp) of+ (True, Array _ (Shape [_]) _) ->+ Just $ M.insert p_nm (arr_nm,slc,p_tp) tab+ _ -> Nothing+ (_, _) -> Nothing+ processIndirections _ _ _ = Nothing++ -- | The second Map accumulator keeps tracks of the arrays that+ -- are variant to the z-parallel dimension and need to be transposed;+ -- the `Int` field refers to the index of the z-variant dimension, and+ -- the `Type` field refers to the type of the original global array.+ -- The first accumulator table is updated to refer to the transposed-array+ -- name, whenever such a case is discovered; otherwise it just accumulates.+ insertTranspose :: VarianceTable -> VName+ -> (M.Map VName (VName, Slice SubExp, Type), M.Map VName (VName,Int,Type))+ -> (VName, (VName, Slice SubExp, Type))+ -> TileM (M.Map VName (VName, Slice SubExp, Type), M.Map VName (VName,Int,Type))+ insertTranspose variance gidz (tab, trnsp) (p_nm, (arr_nm,slc,p_tp)) =+ case findIndex (variantSliceDim variance gidz) slc of+ Nothing -> return (M.insert p_nm (arr_nm,slc,p_tp) tab, trnsp)+ Just i -> do+ arr_tp <- lookupType arr_nm+ arr_tr_nm <- newVName $ baseString arr_nm ++ "_transp"+ let tab' = M.insert p_nm (arr_tr_nm,slc,p_tp) tab+ let trnsp' = M.insert arr_tr_nm (arr_nm, i, arr_tp) trnsp+ return (tab', trnsp')++ variantSliceDim :: VarianceTable -> VName -> DimIndex SubExp -> Bool+ variantSliceDim variance gidz (DimFix (Var vnm)) = variantToOuterDim variance gidz vnm+ variantSliceDim _ _ _ = False++ mkInKerIntMulStmt :: VName -> SubExp -> SubExp -> Stm InKernel+ mkInKerIntMulStmt res_nm0 op1_se op2_se =+ mkLet [] [Ident res_nm0 $ Prim int32] $+ BasicOp $ BinOp (Mul Int32) op1_se op2_se++ retThreadInSpace (ThreadsReturn ThreadsInSpace (Var r)) = Just r+ retThreadInSpace _ = Nothing++doRegTiling3D _ = return Nothing++translateStreamsToLoop :: (Int32,VName,VName,SubExp,VName,VName,SubExp) ->+ VarianceTable ->+ M.Map VName (VName, Slice SubExp, Type) ->+ SubExp -> GroupStreamLambda InKernel ->+ [SubExp] -> [VName] -> [PatElem InKernel]+ -> TileM (Maybe (Exp InKernel, [PatElem InKernel], [PatElem InKernel]))+translateStreamsToLoop (reg_tile, mask,gidz,m_M,mm,local_tid, group_size) variance+ arr_tab w_o lam_o accs_o_p arrs_o_p strm_ress+ | -- 1. We assume the inner stream (of chunk 1) is directly nested+ -- inside the outer stream and also takes its arguments (array+ -- and accumulators) from the outer stream (all checked).+ -- Also all accumulators have primitive types (otherwise+ -- they cannot be efficiently stored in registers anyway).+ accs_o_f <- groupStreamAccParams lam_o,+ arrs_o_f <- groupStreamArrParams lam_o,+ [Let _ _ (Op (GroupStream _ ct1i32 lam_i accs_i_p arrs_i_p))] <-+ stmsToList $ bodyStms $ groupStreamLambdaBody lam_o,+ ct1i32 == (Constant $ IntValue $ Int32Value 1),+ accs_i_f <- groupStreamAccParams lam_i,+ arrs_i_f <- groupStreamArrParams lam_i,+ and $ zipWith (==) (map subExpVar accs_i_p) (map (Just . paramName) accs_o_f),+ and $ zipWith (==) arrs_i_p $ map paramName arrs_o_f,+ all (primType . paramType) accs_o_f,+ -- 2. The intent is to flatten the two streams into a loop, so+ -- we reuse the index of the inner stream for the result-loop index,+ -- and we will modify the body of the inner lambda `body_i` for the+ -- result loop.+ loop_ind_nm <- groupStreamChunkOffset lam_i,+ body_i <- groupStreamLambdaBody lam_i,+ -- 3. We transfer the slicing information (from sclar-code-1) to+ -- the array-formal arguments of the inner stream.+ arr_tab' <- foldl (\ tab (a_o_p, a_o_f, a_i_p, a_i_f) ->+ case (paramName a_o_f == a_i_p, M.lookup a_o_p tab) of+ (True, Just info) -> M.insert (paramName a_i_f) info tab+ _ -> tab+ ) arr_tab $ zip4 arrs_o_p arrs_o_f arrs_i_p arrs_i_f,+ -- 4. We translate the inner stream's accumulator to a FParam, required for+ -- mapping it as a result-loop variant variable.+ accs_i_f' <- map translParamToFParam accs_i_f,+ -- 5. We break the "loop" statements into two parts:+ -- a) the ones invariant to the z parallel dimension `invar_out_stms`,+ -- b) the ones variant to the z parallel dimension `var_out_stms`, and+ -- c) the ones corresponding to indexing operations on variant arrays `var_ind_stms`.+ (invar_out_stms, var_ind_stms, var_out_stms) <-+ foldl (\ (acc_inv, acc_inds, acc_var) stmt ->+ let nm = patElemName $ head $ patternValueElements $ stmPattern stmt+ in if not $ variantToOuterDim variance gidz nm+ then (stmt : acc_inv,acc_inds,acc_var)+ else case stmt of+ Let _ _ (BasicOp (Index arr_nm [DimFix _])) ->+ case M.lookup arr_nm arr_tab' of+ Just _ -> (acc_inv,stmt:acc_inds,acc_var)+ Nothing -> (acc_inv,acc_inds,stmt:acc_var)+ _ -> (acc_inv,acc_inds,stmt:acc_var)+ ) ([],[],[]) $ reverse $ stmsToList $ bodyStms body_i,+ -- 6. We check that the variables used in the index statements referring to+ -- streamed arrays that are variant to the z parallel dimension (`var_ind_stms`)+ -- depend only on variables defined in the invariant stms to the z parallel dimension.+ var_nms <- concatMap (patternNames . stmPattern) var_out_stms,+ null $ S.intersection (S.fromList var_nms) $+ S.unions (map freeInStm var_ind_stms),+ -- 7. We assume (check) for simplicity that all accumulator initializers+ -- of the outer stream are invariant to the z parallel dimension.+ loop_ini_vs <- subExpVars accs_o_p,+ all (not . variantToOuterDim variance gidz) loop_ini_vs,+ -- 8. We assume that all results of the inner-stream body are variables+ -- (for simplicity); they should have been simplified anyways if not!+ loop_res0 <- bodyResult body_i,+ loop_res <- subExpVars loop_res0,+ length loop_res == length loop_res0 = do+ -- I. After all these conditions, we finally start by partitioning+ -- the stream's accumulators and results into the ones that are+ -- variant to the z-parallel dimension and the ones that are not.+ let (loop_var_p_i_r, loop_inv_p_i_r) =+ partition (\(_,_,r,_) -> variantToOuterDim variance gidz r) $+ zip4 accs_i_f' accs_o_p loop_res strm_ress+ -- II. Transform the statements invariant to the z-parallel dimension+ -- so that they perform indexing in the global arrays rather than+ -- in the streamed arrays, i.e., eliminate the indirection.+ inv_stms0 <- mapM (transfInvIndStm arr_tab' loop_ind_nm) invar_out_stms+ let inv_stms = concat inv_stms0+ -- III. the index-statements variant to the z-parallel dimension are+ -- transformed to combined regions.+ m <- newVName "m"+ ind_stms0 <- foldM (transfVarIndStm arr_tab' (reg_tile,loop_ind_nm,local_tid,group_size,m,m_M))+ (Just ([],M.empty)) $ reverse var_ind_stms+ case ind_stms0 of+ Nothing -> return Nothing+ Just (ind_stms, subst_tab) -> do+ -- IV. Add statement `let m = mm + local_tid`+ -- Then perform the substitution `gidz -> m` on the combine regions.+ let m_stmt = mkLet [] [Ident m $ Prim int32] $+ BasicOp $ BinOp (Add Int32) (Var mm) (Var local_tid)+ tab_z_m_comb = M.insert gidz m M.empty+ ind_stms' = m_stmt : map (substituteNames tab_z_m_comb) ind_stms++ -- V. We clone the variant statements regTile times and enclose+ -- each one in a if-then-else testing whether `mm + local_id < m_M`+ -- TODO: check that the statements do not involve In-Place updates!+ let loop_var_p_i_r' = map (\(x,y,z,_)->(x,y,z)) loop_var_p_i_r+ if_ress <- mapM (cloneVarStms subst_tab (mask,loop_ind_nm,mm,m_M,gidz)+ loop_var_p_i_r' var_out_stms) [0..reg_tile-1]+ -- VI. build the loop-variant vars/res/inis+ let (if_stmt_clones0, var_ress_pars) = unzip if_ress+ if_stmt_clones = concat if_stmt_clones0+ (_, var_ini, _, strm_var_res) = unzip4 loop_var_p_i_r+ var_inis = concat $ replicate (fromIntegral reg_tile) var_ini+ (var_ress, var_pars) = unzip $ concat var_ress_pars+ (inv_pars, inv_inis, inv_ress, strm_inv_res) = unzip4 loop_inv_p_i_r+ loop_form_acc = inv_pars ++ var_pars+ loop_inis_acc = inv_inis ++ var_inis+ loop_ress = inv_ress ++ var_ress+ -- VII. Finally build the loop body and return it!+ -- Insert an extra barrier at the begining of the loop; make+ -- it dependent on the loop index so it cannot be hoisted!+ ind_bar <- newVName "loop_ind"+ let bar_stmt = mkLet [] [Ident loop_ind_nm $ Prim int32] $ Op (Barrier [Var ind_bar])+ stms_body_i' = bar_stmt : inv_stms ++ ind_stms' ++ if_stmt_clones+ form = ForLoop ind_bar Int32 w_o []+ body_i' = Body (bodyAttr body_i)+ (stmsFromList stms_body_i') $+ map Var loop_ress+ myloop = DoLoop [] (zip loop_form_acc loop_inis_acc) form body_i'+ free_in_body = freeInBody body_i'+ elim_vars = S.fromList $ arrs_i_p ++ arrs_o_p +++ map paramName arrs_i_f +++ map paramName accs_o_f+ if null $ S.intersection free_in_body elim_vars+ then return $ Just (myloop, strm_inv_res, strm_var_res)+ else return Nothing+translateStreamsToLoop _ _ _ _ _ _ _ _ = return Nothing++-- | Clone the variant statements, by creating a new if-then-else+-- big statement that cheks that `mm + i < m_M` for `i = 0...regTile-1`+-- Return the if-then-else statement together with the result variables+-- so that the body of the loop and the loop results and paramters can+-- be constructed.+-- In order to disallow hoisting from the loop we will generate:+-- let zero = mask & loop_ind+-- let mmpi = zero + mm + i+cloneVarStms :: M.Map VName (VName,Type) -> (VName, VName, VName, SubExp, VName)+ -> [(FParam InKernel, SubExp, VName)] -> [Stm InKernel]+ -> Int32 -> TileM ([Stm InKernel], [(VName,FParam InKernel)])+cloneVarStms subst_tab (mask,loop_ind,mm,m_M,gidz) loop_info var_out_stms i = do+ let (loop_par_origs, loop_inis, body_res_origs) = unzip3 loop_info+ body_res_clones <- mapM (\x -> newVName $ baseString x ++ "_clone") body_res_origs+ loop_par_nm_clones <- mapM (\x -> newVName $ baseString (paramName x) ++ "_clone") loop_par_origs+ m <- newVName "m"+ z <- newVName "zero"+ ii<- newVName "unroll_ct"+ let loop_par_clones = zipWith (\ p nm -> p { paramName = nm })+ loop_par_origs loop_par_nm_clones+ res_types = map paramType loop_par_origs+ i_se = Constant $ IntValue $ Int32Value i++ stmt_zero = mkLet [] [Ident z $ Prim int32] $+ BasicOp $ BinOp (And Int32) (Var mask) (Var loop_ind)+ stmt_ii = mkLet [] [Ident ii $ Prim int32] $+ BasicOp $ BinOp (Add Int32) (Var z) i_se+ m_stmt_other =+ mkLet [] [Ident m $ Prim int32] $+ BasicOp $ BinOp (Add Int32) (Var mm) (Var ii)+ read_sh_stms =+ map (\ (scal,(sh_arr, el_tp)) ->+ mkLet [] [Ident scal el_tp] $+ BasicOp $ Index sh_arr [DimFix i_se]+ ) $ M.toList subst_tab+ tab_z_m_other = foldl (\tab (old,new) -> M.insert (paramName old) new tab)+ (M.insert gidz m M.empty) $+ zip loop_par_origs loop_par_nm_clones+ var_out_stms' = map (substituteNames tab_z_m_other) $+ read_sh_stms ++ var_out_stms+ cond_nm <- newVName "out3_inbounds"+ -- if the statements are simple, i.e., "safe", then do not+ -- encapsulate them in an if-then-else; this will result in+ -- significant performance gains.+ let simple = all simpleStm var_out_stms+ let cond_stm = if simple+ then mkLet [] [Ident cond_nm $ Prim Bool] $+ BasicOp $ SubExp (Constant $ BoolValue True)+ else mkCondStmt m_M m cond_nm+ -- TODO: we need to uniquely rename the then/else bodies!+ then_body <- renameBody $ Body () (stmsFromList var_out_stms') (map Var body_res_origs)+ let else_body = Body () mempty loop_inis+ if_stmt = mkLet [] (zipWith Ident body_res_clones res_types) $+ If (Var cond_nm) then_body else_body $+ IfAttr (staticShapes res_types) IfFallback+ -- we will substitute later the original loop formal-param names+ -- with the newly created ones in the body+ return ( [stmt_zero, stmt_ii, m_stmt_other, cond_stm, if_stmt]+ , zip body_res_clones loop_par_clones )++mkCondStmt :: SubExp -> VName -> VName -> Stm InKernel+mkCondStmt m_M m cond_nm =+ mkLet [] [Ident cond_nm $ Prim Bool] $+ BasicOp $ CmpOp (CmpSlt Int32) (Var m) m_M++simpleStm :: Stm InKernel -> Bool+simpleStm (Let _ _ e) = safeExp e++mkScratchStm :: PatElem Kernels -> TileM (VName, Stm Kernels)+mkScratchStm ker_patel = do+ let (unique_arr_tp, res_arr_nm0) = (patElemType ker_patel, patElemName ker_patel)+ ptp = elemType unique_arr_tp+ scrtch_arr_nm <- newVName $ baseString res_arr_nm0 ++ "_0"+ let scratch_stm = mkLet [] [Ident scrtch_arr_nm unique_arr_tp] $+ BasicOp $ Scratch ptp $ arrayDims unique_arr_tp+ return (scrtch_arr_nm, scratch_stm)++-- | Arguments are:+-- 1. @mm@ this is the length of z-parallel dimension divided by reg_tile+-- 2. @space@: the kernel space+-- 3. @strm_res_nms@: the z-variant results of the original stream+-- 4. @keres_patels@: the kernel result names tupled with the corresponding+-- pattern elements of the kernel statement.+-- 5. @code2_var@: the z-variant statements of the code after the stream.+-- 6. @ip_arr_nms@: the "current" new names for the in-place update arrays.+-- @unroll_code@: the current unrolled code. Both form a `foldM` accumulator.+-- 7. @k@ the "current" clone number;+-- @loop_res_nms@ the names of the loop result corresponding to the current clone.+-- Result:+-- 1. the new name for the current in-place update result,+-- 2. a new if-statement is added to the unrolled-code accumulator which actually+-- perform the in-place update.+cloneVarCode2 :: VName -> KernelSpace -> [VName]+ -> [(VName, PatElem InKernel)] -> [Stm InKernel]+ -> ([VName], [Stm InKernel]) -> (Int32, [VName])+ -> TileM ([VName], [Stm InKernel])+cloneVarCode2 mm space strm_res_nms keres_patels code2_var+ (ip_arr_nms, unroll_code) (k, loop_res_nms) = do+ let (ker_nms, pat_els) = unzip keres_patels+ arr_tps = map patElemType pat_els+ root_strs = map (baseString . patElemName) pat_els+ ip_inn_nms <- mapM (\s -> newVName $ s ++ "_inn_" ++ pretty (k+1)) root_strs+ ip_out_nms <- mapM (\s -> newVName $ s ++ "_out_" ++ pretty (k+1)) root_strs+ m <- newVName "m"+ -- make in-place update statements+ let (gidx,_) : (gidy,_) : (gidz,m_M) : rev_outer_dims = reverse $ spaceDimensions space+ (outer_dims, _) = unzip $ reverse rev_outer_dims+ ip_stmts = map (mkInPlaceStmt (outer_dims++[m,gidy,gidx])) $+ zip4 ip_arr_nms ip_inn_nms ker_nms arr_tps+ -- make if+ cond_nm <- newVName "m_cond"+ let i_se = Constant $ IntValue $ Int32Value k+ m_stm = mkLet [] [Ident m $ Prim int32] $+ BasicOp $ BinOp (Add Int32) (Var mm) i_se+ c_stm = mkCondStmt m_M m cond_nm+ else_body = Body () mempty (map Var ip_arr_nms)+ strm_loop_tab = M.fromList $ (gidz, m) : zip strm_res_nms loop_res_nms+ then_stms = stmsFromList $ map (substituteNames strm_loop_tab) $+ code2_var ++ ip_stmts+ then_body <- renameBody $ Body () then_stms $ map Var ip_inn_nms+ let if_stm = mkLet [] (zipWith Ident ip_out_nms arr_tps) $+ If (Var cond_nm) then_body else_body $+ IfAttr (staticShapes arr_tps) IfFallback+ return (ip_out_nms, unroll_code ++ [m_stm, c_stm, if_stm])+ where mkInPlaceStmt :: [VName] -> (VName, VName, VName, Type)+ -> Stm InKernel+ mkInPlaceStmt inds (cur_nm, new_nm, ker_nm, arr_tp) =+ let upd_slc = map (DimFix . Var) inds+ ipupd_exp = BasicOp $ Update cur_nm upd_slc (Var ker_nm)+ in mkLet [] [Ident new_nm arr_tp] ipupd_exp++helper3Stms :: VName -> SubExp -> SubExp -> Slice SubExp+ -> VName -> Stm InKernel -> TileM [Stm InKernel]+helper3Stms loop_ind strd beg par_slc par_arr (Let ptt att _) = do+ tmp1 <- newVName "tmp"+ tmp2 <- newVName "ind"+ let stmt1 = mkLet [] [Ident tmp1 $ Prim int32] $+ BasicOp $ BinOp (Mul Int32) (Var loop_ind) strd+ stmt2 = mkLet [] [Ident tmp2 $ Prim int32] $+ BasicOp $ BinOp (Add Int32) beg (Var tmp1)+ ndims = length par_slc+ ind_exp = BasicOp (Index par_arr (take (ndims-1) par_slc ++ [DimFix $ Var tmp2]))+ stmt3 = Let ptt att ind_exp+ return [stmt1,stmt2,stmt3]++-- | Insert the necessary translations for a statement that is indexing+-- in one of the streamed arrays, which is invariant to the z-parallel+-- dimension. The index is necessarily `0` at this point, and we use `tab`+-- to figure out to what global array does the streamed array actually+-- refers to, and to compute the global index.+transfInvIndStm :: M.Map VName (VName, Slice SubExp, Type)+ -> VName -> Stm InKernel+ -> TileM [Stm InKernel]+transfInvIndStm tab loop_ind stm@(Let _ _ (BasicOp (Index arr_nm [DimFix _])))+ | Just (par_arr, par_slc@(_:_), _) <- M.lookup arr_nm tab,+ DimSlice beg _ strd <- last par_slc =+ helper3Stms loop_ind strd beg par_slc par_arr stm+transfInvIndStm _ _ stm = return [stm]++-- | Insert the necessary translations for a statement that is indexing+-- inside one of the streamed arrays, which is variant to the outermost+-- parallel dimension.+transfVarIndStm :: M.Map VName (VName, Slice SubExp, Type)+ -> (Int32,VName,VName,SubExp,VName,SubExp)+ -> Maybe ([Stm InKernel],M.Map VName (VName,Type))+ -> Stm InKernel+ -> TileM (Maybe ([Stm InKernel],M.Map VName (VName,Type)))+transfVarIndStm tab (reg_tile,loop_ind,local_tid,group_size,m,m_M) acc+ stm@(Let ptt _ (BasicOp (Index arr_nm [DimFix _])))+ | Just (tstms,stab) <- acc,+ Just (par_arr, par_slc@(_:_), _) <- M.lookup arr_nm tab,+ DimSlice beg _ strd <- last par_slc,+ [pat_el] <- patternValueElements ptt,+ el_tp <- patElemType pat_el,+ pat_el_nm <- patElemName pat_el,+ Prim _ <- el_tp = do+ -- compute the index into the global array+ stms3 <- helper3Stms loop_ind strd beg par_slc par_arr stm+ let glb_ind_stms = stmsFromList stms3+ -- set up the combine part+ sh_arr_1d <- newVName $ baseString par_arr ++ "_sh_1d"+ cid <- newVName "cid"+ let block_cspace = combineSpace [(cid,group_size)]+ comb_exp = Op $ Combine block_cspace [el_tp]+ [(local_tid, mkRegTileSe reg_tile), (m,m_M)] $+ Body () glb_ind_stms [Var pat_el_nm]+ sh_arr_pe = PatElem sh_arr_1d $+ arrayOfShape el_tp $ Shape [group_size]+ write_sh_arr_stmt =+ Let (Pattern [] [sh_arr_pe]) (defAux ()) comb_exp+ return $ Just (write_sh_arr_stmt:tstms, M.insert pat_el_nm (sh_arr_1d,el_tp) stab)+transfVarIndStm _ _ _ _ = return Nothing++--------------+--- HELPES ---+--------------++-- | translates an LParam to an FParam+translParamToFParam :: LParam InKernel -> FParam InKernel+translParamToFParam = fmap (`toDecl` Nonunique)++-- | Tries to identified the following pattern:+-- code folowed by a group stream followed by+-- another code.+matchCodeStreamCode :: Stms InKernel ->+ ([Stm InKernel], Maybe (Stm InKernel), [Stm InKernel])+matchCodeStreamCode kstms =+ foldl (\acc stmt ->+ case (acc,stmt) of+ ( (cd1,Nothing,cd2), Let _ _ (Op GroupStream{})) ->+ (cd1, Just stmt, cd2)+ ( (cd1, Nothing, cd2), _) -> (cd1++[stmt], Nothing, cd2)+ ( (cd1,Just strm,cd2), _) -> (cd1,Just strm,cd2++[stmt])+ ) ([],Nothing,[]) (stmsToList kstms)++-- | Checks that all streamed arrays are variant to exacly one of+-- the three innermost parallel dimensions, and conversly for+-- each of the three innermost parallel dimensions, there is at+-- least one streamed array variant to it. The result is the+-- the number of the only variant parallel dimension for each array.+is3dTileable :: Names -> KernelSpace -> VarianceTable -> [VName]+ -> [LParam InKernel] -> Maybe [Int]+is3dTileable branch_variant kspace variance arrs block_params =+ let ok1 = all (primType . rowType . paramType) block_params+ inner_perm0 = map variantOnlyToOneOfThreeInnerDims arrs+ inner_perm = catMaybes inner_perm0+ ok2 = elem 0 inner_perm && elem 1 inner_perm && elem 2 inner_perm+ ok3 = length inner_perm0 == length inner_perm+ ok = ok1 && ok2 && ok3+ in if ok then Just inner_perm else Nothing+ where variantOnlyToOneOfThreeInnerDims :: VName -> Maybe Int+ variantOnlyToOneOfThreeInnerDims arr = do+ (k,_) : (j,_) : (i,_) : _ <- Just $ reverse $ spaceDimensions kspace+ let variant_to = M.findWithDefault mempty arr variance+ branch_invariant = not $ S.member k branch_variant ||+ S.member j branch_variant ||+ S.member i branch_variant+ if not branch_invariant+ then Nothing+ else if i `S.member` variant_to && not (j `S.member` variant_to) && not (k `S.member` variant_to) then Just 0+ else if not (i `S.member` variant_to) && j `S.member` variant_to && not (k `S.member` variant_to) then Just 1+ else if not (i `S.member` variant_to) && not (j `S.member` variant_to) && k `S.member` variant_to then Just 2+ else Nothing++mkKerSpaceExtraStms :: Int32 -> [(VName, SubExp)]+ -> TileM (Stms Kernels, SpaceStructure, SubExp, SubExp, SubExp)+mkKerSpaceExtraStms reg_tile gspace = do+ dim_z_nm <- newVName "gidz_range"+ tmp <- newVName "tmp"+ let tmp_stm = mkLet [] [Ident tmp $ Prim int32] $+ BasicOp $ BinOp (Add Int32) m_M $+ Constant $ IntValue $ Int32Value (reg_tile-1)+ rgz_stm = mkLet [] [Ident dim_z_nm $ Prim int32] $+ BasicOp $ BinOp (SQuot Int32) (Var tmp) $+ Constant $ IntValue $ Int32Value reg_tile+ (gidx,sz_x) : (gidy,sz_y) : (gidz,m_M) : untiled_gspace = reverse gspace++ ((tile_size_x, tile_size_y, tiled_group_size), tile_size_bnds) <- runBinder $ do+ tile_size_key <- newVName "tile_size"+ tile_ct_size <- letSubExp "tile_size" $ Op $ GetSize tile_size_key SizeTile+ tile_size_x <- letSubExp "tile_size_x" $ BasicOp $+ BinOp (SMin Int32) tile_ct_size sz_x+ tile_size_y <- letSubExp "tile_size_y" $ BasicOp $+ BinOp (SMin Int32) tile_ct_size sz_y+ tiled_group_size <- letSubExp "tiled_group_size" $+ BasicOp $ BinOp (Mul Int32) tile_size_x tile_size_y+ return (tile_size_x, tile_size_y, tiled_group_size)+ -- Play with reversion to ensure we get increasing IDs for+ -- ltids. This affects readability of generated code.+ untiled_gspace' <- fmap reverse $ forM (reverse untiled_gspace) $ \(gtid,gdim) -> do+ ltid <- newVName "ltid"+ return (gtid, gdim, ltid, constant (1::Int32))+ ltidz <- newVName "ltid"+ let dim_z = (gidz, Var dim_z_nm, ltidz, constant (1::Int32))+ ltidy <- newVName "ltid"+ let dim_y = (gidy, sz_y, ltidy, tile_size_y)+ ltidx <- newVName "ltid"+ let dim_x = (gidx, sz_x, ltidx, tile_size_x)+ gspace' = reverse $ dim_x : dim_y : dim_z : untiled_gspace'+ -- We have to recalculate number of workgroups and+ -- number of threads to fit the new workgroup size.+ ((num_threads, num_groups), num_bnds) <-+ runBinder $ sufficientGroups gspace' tiled_group_size++ let extra_stms = oneStm tmp_stm <> oneStm rgz_stm <> tile_size_bnds <> num_bnds+ return ( extra_stms, NestedThreadSpace gspace'+ , tiled_group_size, num_threads, num_groups )+++variantToOuterDim :: VarianceTable -> VName -> VName -> Bool+variantToOuterDim variance gid_outer nm =+ gid_outer == nm || gid_outer `S.member` M.findWithDefault mempty nm variance++varianceInStms :: VarianceTable -> Stms InKernel -> VarianceTable+varianceInStms = foldl varianceInStm++varianceInStm :: VarianceTable -> Stm InKernel -> VarianceTable+varianceInStm v0 bnd@(Let _ _ (Op (GroupStream _ _ lam accs arrs))) =+ let v = defVarianceInStm v0 bnd+ acc_lam_f = groupStreamAccParams lam+ arr_lam_f = groupStreamArrParams lam+ bdy_lam = groupStreamLambdaBody lam+ stm_lam = bodyStms bdy_lam++ v' = foldl' (\vacc (v_a, v_f) ->+ let vrc = S.insert v_a $ M.findWithDefault mempty v_a vacc+ in M.insert v_f vrc vacc+ ) v $ zip arrs $ map paramName arr_lam_f+ v''= foldl' (\vacc (v_se, v_f) ->+ case v_se of+ Var v_a ->+ let vrc = S.insert v_a $ M.findWithDefault mempty v_a vacc+ in M.insert v_f vrc vacc+ Constant _ -> vacc+ ) v' $ zip accs $ map paramName acc_lam_f+ in varianceInStms v'' stm_lam+varianceInStm variance bnd = defVarianceInStm variance bnd++defVarianceInStm :: VarianceTable -> Stm InKernel -> VarianceTable+defVarianceInStm variance bnd =+ foldl' add variance $ patternNames $ stmPattern bnd+ where add variance' v = M.insert v binding_variance variance'+ look variance' v = S.insert v $ M.findWithDefault mempty v variance'+ binding_variance = mconcat $ map (look variance) $ S.toList (freeInStm bnd)++sufficientGroups :: MonadBinder m =>+ [(VName, SubExp, VName, SubExp)] -> SubExp+ -> m (SubExp, SubExp)+sufficientGroups gspace group_size = do+ groups_in_dims <- forM gspace $ \(_, gd, _, ld) ->+ letSubExp "groups_in_dim" =<< eDivRoundingUp Int32 (eSubExp gd) (eSubExp ld)+ num_groups <- letSubExp "num_groups" =<<+ foldBinOp (Mul Int32) (constant (1::Int32)) groups_in_dims+ num_threads <- letSubExp "num_threads" $+ BasicOp $ BinOp (Mul Int32) num_groups group_size+ return (num_threads, num_groups)
src/Futhark/Pass/ExplicitAllocations.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, FlexibleContexts, TupleSections, FlexibleInstances, MultiParamTypeClasses #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE DefaultSignatures #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Futhark.Pass.ExplicitAllocations ( explicitAllocations@@ -57,10 +58,31 @@ class (MonadFreshNames m, HasScope lore m, ExplicitMemorish lore) => Allocator lore m where addAllocStm :: AllocStm -> m ()++ default addAllocStm :: (Allocable fromlore lore,+ Op lore ~ MemOp inner,+ m ~ AllocM fromlore lore)+ => AllocStm -> m ()+ addAllocStm (SizeComputation name se) =+ letBindNames_ [name] =<< toExp (coerceIntPrimExp Int64 se)+ addAllocStm (Allocation name size space) =+ letBindNames_ [name] $ Op $ Alloc size space+ addAllocStm (ArrayCopy name src) =+ letBindNames_ [name] $ BasicOp $ Copy src+ -- | The subexpression giving the number of elements we should -- allocate space for. See 'ChunkMap' comment. dimAllocationSize :: SubExp -> m SubExp + default dimAllocationSize :: m ~ AllocM fromlore lore+ => SubExp -> m SubExp+ dimAllocationSize (Var v) =+ -- It is important to recurse here, as the substitution may itself+ -- be a chunk size.+ maybe (return $ Var v) dimAllocationSize =<< asks (M.lookup v . chunkMap)+ dimAllocationSize size =+ return size+ expHints :: Exp lore -> m [ExpHint] expHints e = return $ replicate (expExtTypeSize e) NoHint @@ -141,38 +163,10 @@ instance Allocable fromlore OutInKernel => Allocator ExplicitMemory (AllocM fromlore ExplicitMemory) where- addAllocStm (SizeComputation name se) =- letBindNames_ [name] =<< toExp (coerceIntPrimExp Int64 se)- addAllocStm (Allocation name size space) =- letBindNames_ [name] $ Op $ Alloc size space- addAllocStm (ArrayCopy name src) =- letBindNames_ [name] $ BasicOp $ Copy src-- dimAllocationSize (Var v) =- -- It is important to recurse here, as the substitution may itself- -- be a chunk size.- maybe (return $ Var v) dimAllocationSize =<< asks (M.lookup v . chunkMap)- dimAllocationSize size =- return size- expHints = kernelExpHints instance Allocable fromlore OutInKernel => Allocator OutInKernel (AllocM fromlore OutInKernel) where- addAllocStm (SizeComputation name se) =- letBindNames_ [name] =<< toExp (coerceIntPrimExp Int64 se)- addAllocStm (Allocation name size space) =- letBindNames_ [name] $ Op $ Alloc size space- addAllocStm (ArrayCopy name src) =- letBindNames_ [name] $ BasicOp $ Copy src-- dimAllocationSize (Var v) =- -- It is important to recurse here, as the substitution may itself- -- be a chunk size.- maybe (return $ Var v) dimAllocationSize =<< asks (M.lookup v . chunkMap)- dimAllocationSize size =- return size- expHints = inKernelExpHints runAllocM :: MonadFreshNames m =>@@ -680,7 +674,20 @@ space_oks <- mkSpaceOks (length rets) tbranch' fbranch' <- allocInFunBody space_oks fbranch let rets' = createBodyReturns rets space_oks- return $ If cond tbranch' fbranch' $ IfAttr rets' ifsort+ res_then = bodyResult tbranch'+ res_else = bodyResult fbranch'+ size_ext = length res_then - length rets'+ (ind_ses0, r_then_else) =+ foldl (\(acc_ise,acc_ext) (r_then, r_else, i) ->+ if r_then == r_else then ((i,r_then):acc_ise, acc_ext)+ else (acc_ise, (r_then, r_else):acc_ext)+ ) ([],[]) $ reverse $ zip3 res_then res_else [0..size_ext-1]+ (r_then_ext, r_else_ext) = unzip r_then_else+ ind_ses = zipWith (\(i,se) k -> (i-k,se)) ind_ses0 [0..length ind_ses0 - 1]+ rets'' = foldl (\acc (i,se) -> fixExt i se acc) rets' ind_ses+ tbranch'' = tbranch' { bodyResult = r_then_ext ++ drop size_ext res_then }+ fbranch'' = fbranch' { bodyResult = r_else_ext ++ drop size_ext res_else }+ return $ If cond tbranch'' fbranch'' $ IfAttr rets'' ifsort allocInExp e = mapExpM alloc e where alloc = identityMapper { mapOnBody = fail "Unhandled Body in ExplicitAllocations"
src/Futhark/Pass/ExtractKernels/Segmented.hs view
@@ -15,7 +15,7 @@ import Futhark.Representation.Kernels import Futhark.Representation.SOACS.SOAC (nilFn) import Futhark.MonadFreshNames-import Futhark.Tools+import Futhark.Tools hiding (true, false) import Futhark.Pass.ExtractKernels.BlockedKernel data SegmentedVersion = OneGroupOneSegment
src/Futhark/Pass/KernelBabysitting.hs view
@@ -69,14 +69,15 @@ transformStm :: ExpMap -> Stm Kernels -> BabysitM ExpMap -transformStm expmap (Let pat aux (Op (Kernel desc space ts kbody))) = do+transformStm expmap (Let pat aux ke@(Op (Kernel desc space ts kbody))) = do -- Go spelunking for accesses to arrays that are defined outside the -- kernel body and where the indices are kernel thread indices. scope <- askScope let thread_gids = map fst $ spaceDimensions space thread_local = S.fromList $ spaceGlobalId space : spaceLocalId space : thread_gids-+ free_ker_vars = freeInExp ke `S.difference` getKerVariantIds space kbody'' <- evalStateT (traverseKernelBodyArrayIndexes+ free_ker_vars thread_local (castScope scope <> scopeOfKernelSpace space) (ensureCoalescedAccess expmap (spaceDimensions space) num_threads)@@ -87,6 +88,12 @@ addStm bnd' return $ M.fromList [ (name, bnd') | name <- patternNames pat ] <> expmap where num_threads = spaceNumThreads space+ getKerVariantIds (KernelSpace glb_id loc_id grp_id _ _ _ (FlatThreadSpace strct)) =+ let (gids, _) = unzip strct+ in S.fromList $ [glb_id, loc_id, grp_id] ++ gids+ getKerVariantIds (KernelSpace glb_id loc_id grp_id _ _ _ (NestedThreadSpace strct)) =+ let (gids, _, lids, _) = unzip4 strct+ in S.fromList $ [glb_id, loc_id, grp_id] ++ gids ++ lids transformStm expmap (Let pat aux e) = do e' <- mapExpM (transform expmap) e@@ -99,18 +106,21 @@ identityMapper { mapOnBody = \scope -> localScope scope . transformBody expmap } type ArrayIndexTransform m =+ Names -> (VName -> Bool) -> -- thread local?+ (VName -> SubExp -> Bool)-> -- variant to a certain gid (given as first param)? (SubExp -> Maybe SubExp) -> -- split substitution? Scope InKernel -> -- type environment VName -> Slice SubExp -> m (Maybe (VName, Slice SubExp)) traverseKernelBodyArrayIndexes :: (Applicative f, Monad f) => Names+ -> Names -> Scope InKernel -> ArrayIndexTransform f -> KernelBody InKernel -> f (KernelBody InKernel)-traverseKernelBodyArrayIndexes thread_variant outer_scope f (KernelBody () kstms kres) =+traverseKernelBodyArrayIndexes free_ker_vars thread_variant outer_scope f (KernelBody () kstms kres) = KernelBody () . stmsFromList <$> mapM (onStm (varianceInStms mempty kstms, mkSizeSubsts kstms,@@ -134,12 +144,16 @@ scope' = scope <> scopeOf stms onStm (variance, szsubst, _) (Let pat attr (BasicOp (Index arr is))) =- Let pat attr . oldOrNew <$> f isThreadLocal sizeSubst outer_scope arr is+ Let pat attr . oldOrNew <$> f free_ker_vars isThreadLocal isGidVariant sizeSubst outer_scope arr is where oldOrNew Nothing = BasicOp $ Index arr is oldOrNew (Just (arr', is')) = BasicOp $ Index arr' is' + isGidVariant gid (Var v) =+ gid == v || S.member gid (M.findWithDefault (S.singleton v) v variance)+ isGidVariant _ _ = False+ isThreadLocal v = not $ S.null $ thread_variant `S.intersection`@@ -177,7 +191,8 @@ -> [(VName,SubExp)] -> SubExp -> ArrayIndexTransform (StateT Replacements m)-ensureCoalescedAccess expmap thread_space num_threads isThreadLocal sizeSubst outer_scope arr slice = do+ensureCoalescedAccess expmap thread_space num_threads free_ker_vars isThreadLocal+ isGidVariant sizeSubst outer_scope arr slice = do seen <- gets $ M.lookup (arr, slice) case (seen, isThreadLocal arr, typeOf <$> M.lookup arr outer_scope) of@@ -190,7 +205,7 @@ -- indices are in a permuted order. | Just is <- sliceIndices slice, length is == arrayRank t,- Just is' <- coalescedIndexes (map Var thread_gids) is,+ Just is' <- coalescedIndexes free_ker_vars isGidVariant (map Var thread_gids) is, Just perm <- is' `isPermutationOf` is -> replace =<< lift (rearrangeInput (nonlinearInMemory arr expmap) perm arr) @@ -205,11 +220,14 @@ | Just (Let _ _ (BasicOp (Rearrange perm _))) <- M.lookup arr expmap, ---- Just (Just perm) <- nonlinearInMemory arr expmap, not $ null perm,+ not $ null thread_gids,+ inner_gid <- last thread_gids, length slice >= length perm, slice' <- map (\i -> slice !! i) perm, DimFix inner_ind <- last slice', not $ null thread_gids,- inner_ind == (Var $ last thread_gids) ->+ isGidVariant inner_gid inner_ind ->+-- inner_ind == (Var $ inner_gid) -> return Nothing -- We are not fully indexing an array, but the remaining slice@@ -262,7 +280,7 @@ -- order! Make sure that is the case. | Just{} <- nonlinearInMemory arr expmap -> case sliceIndices slice of- Just is | Just _ <- coalescedIndexes (map Var thread_gids) is ->+ Just is | Just _ <- coalescedIndexes free_ker_vars isGidVariant (map Var thread_gids) is -> replace =<< lift (rowMajorArray arr) | otherwise -> return Nothing@@ -296,18 +314,23 @@ allDimAreSlice (_:is) = allDimAreSlice is -- Try to move thread indexes into their proper position.-coalescedIndexes :: [SubExp] -> [SubExp] -> Maybe [SubExp]-coalescedIndexes tgids is+coalescedIndexes :: Names -> (VName -> SubExp -> Bool) -> [SubExp] -> [SubExp] -> Maybe [SubExp]+coalescedIndexes free_ker_vars isGidVariant tgids is -- Do Nothing if:- -- 1. the innermost index is the innermost thread id- -- (because access is already coalesced)- -- 2. any of the indices is a constant, i.e., kernel free variable+ -- 1. any of the indices is a constant or a kernel free variable -- (because it would transpose a bigger array then needed -- big overhead).+ -- 2. the innermost index is variant to the innermost-thread gid+ -- (because access is likely to be already coalesced) | any isCt is =- Nothing- | num_is > 0 && not (null tgids) && last is == last tgids =- Just is- -- Otherwise try fix coalescing+ Nothing+ | any (`S.member` free_ker_vars) (mapMaybe mbVarId is) =+ Nothing+ | not (null tgids),+ not (null is),+ Var innergid <- last tgids,+ num_is > 0 && isGidVariant innergid (last is) =+ Just is+ -- 3. Otherwise try fix coalescing | otherwise = Just $ reverse $ foldl move (reverse is) $ zip [0..] (reverse tgids) where num_is = length is@@ -334,6 +357,9 @@ isCt :: SubExp -> Bool isCt (Constant _) = True isCt (Var _) = False++ mbVarId (Constant _) = Nothing+ mbVarId (Var v) = Just v coalescingPermutation :: Int -> Int -> [Int] coalescingPermutation num_is rank =
src/Futhark/Passes.hs view
@@ -37,6 +37,7 @@ standardPipeline = passes [ simplifySOACS , inlineAndRemoveDeadFunctions+ , simplifySOACS , performCSE True , simplifySOACS -- We run fusion twice
src/Futhark/Representation/AST/Attributes.hs view
@@ -31,6 +31,7 @@ , stmCerts , certify , expExtTypesFromPattern+ , patternFromParams , IsOp (..) , Attributes (..)@@ -222,3 +223,8 @@ expExtTypesFromPattern pat = existentialiseExtTypes (patternContextNames pat) $ staticShapes $ map patElemType $ patternValueElements pat++-- | Create a pattern corresponding to some parameters.+patternFromParams :: [Param attr] -> PatternT attr+patternFromParams = Pattern [] . map toPatElem+ where toPatElem p = PatElem (paramName p) $ paramAttr p
src/Futhark/Representation/AST/Attributes/Aliases.hs view
@@ -74,8 +74,6 @@ [mempty] primOpAliases Assert{} = [mempty]-primOpAliases (Partition n _ arr) =- replicate n mempty ++ map vnameAliases arr ifAliases :: ([Names], Names) -> ([Names], Names) -> [Names] ifAliases (als1,cons1) (als2,cons2) =
src/Futhark/Representation/AST/Attributes/Ranges.hs view
@@ -210,8 +210,6 @@ [rangeOf $ Var se] primOpRanges (Index v _) = [rangeOf $ Var v]-primOpRanges (Partition n _ arr) =- replicate n unknownRange ++ map (rangeOf . Var) arr primOpRanges (ArrayLit (e:es) _) = [(Just lower, Just upper)] where (e_lower, e_upper) = subExpKnownRange e
src/Futhark/Representation/AST/Attributes/TypeOf.hs view
@@ -119,10 +119,6 @@ pure <$> lookupType v primOpType Assert{} = pure [Prim Cert]-primOpType (Partition n _ arrays) =- result <$> traverse lookupType arrays- where result ts = replicate n (Prim $ IntType Int32) ++ ts- -- | The type of an expression. expExtType :: (HasScope lore m, TypedOp (Op lore)) =>
src/Futhark/Representation/AST/Pretty.hs view
@@ -206,9 +206,6 @@ 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]- ppr (Partition n flags arrs) =- text "partition" <>- parens (commasep $ [ ppr n, ppr flags ] ++ map ppr arrs) instance Pretty a => Pretty (ErrorMsg a) where ppr (ErrorMsg parts) = commasep $ map p parts
src/Futhark/Representation/AST/Syntax.hs view
@@ -263,11 +263,6 @@ -- ^ 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.-- | Partition Int VName [VName]- -- ^ First variable is the flag array, second is the element- -- arrays. If no arrays are given, the returned offsets are zero,- -- and no arrays are returned. deriving (Eq, Ord, Show) -- | The root Futhark expression type. The 'Op' constructor contains
src/Futhark/Representation/AST/Syntax/Core.hs view
@@ -302,10 +302,10 @@ (orig_k+i*orig_s) : fixSlice mis' is' fixSlice _ _ = [] --- | An element of a pattern - consisting of an name (essentially a--- pair of the name andtype), a 'Bindage', and an addditional--- parametric attribute. This attribute is what is expected to--- contain the type of the resulting variable.+-- | 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
src/Futhark/Representation/AST/Traversals.hs view
@@ -149,9 +149,6 @@ BasicOp <$> (Assert <$> mapOnSubExp tv e <*> traverse (mapOnSubExp tv) msg <*> pure loc) mapExpM tv (BasicOp (Opaque e)) = BasicOp <$> (Opaque <$> mapOnSubExp tv e)-mapExpM tv (BasicOp (Partition n flags arr)) =- BasicOp <$> (Partition <$>- pure n <*> mapOnVName tv flags <*> mapM (mapOnVName tv) arr) mapExpM tv (DoLoop ctxmerge valmerge form loopbody) = do ctxparams' <- mapM (mapOnFParam tv) ctxparams valparams' <- mapM (mapOnFParam tv) valparams
src/Futhark/Representation/ExplicitMemory.hs view
@@ -503,32 +503,30 @@ bodyReturnsToExpReturns :: BodyReturns -> ExpReturns bodyReturnsToExpReturns = noUniquenessReturns . maybeReturns +instance TC.CheckableOp ExplicitMemory where+ checkOp (Alloc size _) = TC.require [Prim int64] size+ checkOp (Inner k) = TC.subCheck $ typeCheckKernel k++instance TC.CheckableOp InKernel where+ checkOp (Alloc size _) = TC.require [Prim int64] size+ checkOp (Inner k) = TC.subCheck $ typeCheckKernelExp k+ instance TC.Checkable ExplicitMemory where- checkExpLore = return- checkBodyLore = return checkFParamLore = checkMemInfo checkLParamLore = checkMemInfo checkLetBoundLore = checkMemInfo checkRetType = mapM_ TC.checkExtType . retTypeValues- checkOp (Alloc size _) = TC.require [Prim int64] size- checkOp (Inner k) = TC.subCheck $ typeCheckKernel k primFParam name t = return $ Param name (MemPrim t)- primLParam name t = return $ Param name (MemPrim t) matchPattern = matchPatternToExp matchReturnType = matchFunctionReturnType matchBranchType = matchBranchReturnType instance TC.Checkable InKernel where- checkExpLore = return- checkBodyLore = return checkFParamLore = checkMemInfo checkLParamLore = checkMemInfo checkLetBoundLore = checkMemInfo checkRetType = mapM_ TC.checkExtType . retTypeValues- checkOp (Alloc size _) = TC.require [Prim int64] size- checkOp (Inner k) = typeCheckKernelExp k primFParam name t = return $ Param name (MemPrim t)- primLParam name t = return $ Param name (MemPrim t) matchPattern = matchPatternToExp matchReturnType = matchFunctionReturnType matchBranchType = matchBranchReturnType
src/Futhark/Representation/Kernels.hs view
@@ -16,8 +16,6 @@ ) where -import Control.Monad- import Futhark.Representation.AST.Syntax import Futhark.Representation.Kernels.Kernel import Futhark.Representation.Kernels.KernelExp@@ -47,37 +45,15 @@ expTypesFromPattern = return . expExtTypesFromPattern instance PrettyLore InKernel where -instance TypeCheck.Checkable Kernels where- checkExpLore = return- checkBodyLore = return- checkFParamLore _ = TypeCheck.checkType- checkLParamLore _ = TypeCheck.checkType- checkLetBoundLore _ = TypeCheck.checkType- checkRetType = mapM_ TypeCheck.checkExtType . retTypeValues+instance TypeCheck.CheckableOp Kernels where checkOp = TypeCheck.subCheck . typeCheckKernel- matchPattern pat = TypeCheck.matchExtPattern pat <=< expExtType- primFParam name t =- return $ Param name (Prim t)- primLParam name t =- return $ Param name (Prim t)- matchReturnType = TypeCheck.matchExtReturnType . map fromDecl- matchBranchType = TypeCheck.matchExtBranchType +instance TypeCheck.CheckableOp InKernel where+ checkOp = TypeCheck.subCheck . typeCheckKernelExp++instance TypeCheck.Checkable Kernels where+ instance TypeCheck.Checkable InKernel where- checkExpLore = return- checkBodyLore = return- checkFParamLore _ = TypeCheck.checkType- checkLParamLore _ = TypeCheck.checkType- checkLetBoundLore _ = TypeCheck.checkType- checkRetType = mapM_ TypeCheck.checkExtType . retTypeValues- checkOp = typeCheckKernelExp- matchPattern pat = TypeCheck.matchExtPattern pat <=< expExtType- primFParam name t =- return $ Param name (Prim t)- primLParam name t =- return $ Param name (Prim t)- matchReturnType = TypeCheck.matchExtReturnType . map fromDecl- matchBranchType = TypeCheck.matchExtBranchType instance Bindable Kernels where mkBody = Body ()
src/Futhark/Representation/Kernels/KernelExp.hs view
@@ -438,8 +438,9 @@ instance ST.IndexOp (KernelExp lore) where instance Aliased lore => UsageInOp (KernelExp lore) where- usageInOp (Combine _ _ _ body) =- mconcat $ map UT.consumedUsage $ S.toList $ consumedInBody body+ usageInOp (Combine cspace _ _ body) =+ mconcat $ map UT.consumedUsage $ S.toList (consumedInBody body) <>+ [ arr | (_, _, arr) <- cspaceScatter cspace ] usageInOp _ = mempty instance OpMetrics (Op lore) => OpMetrics (KernelExp lore) where@@ -478,10 +479,12 @@ forM_ ts_is $ \ts_i -> unless (Prim int32 == ts_i) $ TC.bad $ TC.TypeError "Combine: index return type must be i32." - forM_ (zip (chunks as_ns ts_vs) scatter) $ \(ts_vs', (aw, _, a)) -> do+ to_consume <- forM (zip (chunks as_ns ts_vs) scatter) $ \(ts_vs', (aw, _, a)) -> do TC.require [Prim int32] aw forM_ ts_vs' $ \ts_v -> TC.requireI [ts_v `arrayOfRow` aw] a- TC.consume =<< TC.lookupAliases a+ return a+ -- Consume all at once because it is valid to do two scatters to the same array.+ TC.consume . mconcat =<< mapM TC.lookupAliases to_consume mapM_ TC.checkType ts mapM_ (TC.requireI [Prim int32]) a_is
src/Futhark/Representation/Kernels/Simplify.hs view
@@ -65,7 +65,7 @@ space' <- Engine.simplify space ts' <- mapM Engine.simplify ts outer_vtable <- Engine.askVtable- (((kbody_stms, kbody_res), kbody_hoisted), again) <-+ ((kbody_stms, kbody_res), kbody_hoisted) <- Engine.subSimpleM (mk_ops space) env outer_vtable $ do par_blocker <- Engine.asksEngineEnv $ Engine.blockHoistPar . Engine.envHoistBlockers Engine.localVtable (<>scope_vtable) $@@ -74,7 +74,6 @@ `Engine.orIf` par_blocker `Engine.orIf` Engine.isConsumed) $ simplifyKernelBodyM kbody- when again Engine.changed kbody_hoisted' <- mapM processHoistedStm kbody_hoisted return (Kernel desc space' ts' $ mkWiseKernelBody () kbody_stms kbody_res, kbody_hoisted')
src/Futhark/Representation/Primitive.hs view
@@ -68,6 +68,8 @@ , negativeIsh , primBitSize , primByteSize+ , intByteSize+ , floatByteSize , commutativeBinOp -- * Prettyprinting
src/Futhark/Representation/SOACS.hs view
@@ -34,8 +34,6 @@ ) where -import Control.Monad- import qualified Futhark.Representation.AST.Syntax as AST import Futhark.Representation.AST.Syntax hiding (Prog, BasicOp, Exp, Body, Stm,@@ -74,21 +72,10 @@ type RetType = AST.RetType SOACS type PatElem = AST.PatElem SOACS -instance TypeCheck.Checkable SOACS where- checkExpLore = return- checkBodyLore = return- checkFParamLore _ = TypeCheck.checkType- checkLParamLore _ = TypeCheck.checkType- checkLetBoundLore _ = TypeCheck.checkType- checkRetType = mapM_ TypeCheck.checkExtType . retTypeValues+instance TypeCheck.CheckableOp SOACS where checkOp = typeCheckSOAC- matchPattern pat = TypeCheck.matchExtPattern pat <=< expExtType- primFParam name t =- return $ AST.Param name (AST.Prim t)- primLParam name t =- return $ AST.Param name (AST.Prim t)- matchReturnType = TypeCheck.matchExtReturnType . map fromDecl- matchBranchType = TypeCheck.matchExtBranchType++instance TypeCheck.Checkable SOACS where instance Bindable SOACS where mkBody = AST.Body ()
src/Futhark/Representation/SOACS/SOAC.hs view
@@ -12,13 +12,13 @@ , Scan , Reduce - , typeCheckSOAC- -- * Utility , getStreamOrder , getStreamAccums , scremaType , soacType++ , typeCheckSOAC , mkIdentityLambda , isIdentityLambda
src/Futhark/Representation/SOACS/Simplify.hs view
@@ -163,6 +163,7 @@ RuleOp removeDeadWrite, RuleBasicOp removeUnnecessaryCopy, RuleOp liftIdentityMapping,+ RuleOp liftIdentityStreaming, RuleOp removeDuplicateMapOutput, RuleOp mapOpToOp ]@@ -207,6 +208,35 @@ mapM_ (uncurry letBind) invariant letBindNames_ (map patElemName pat') $ Op $ Screma w (mapSOAC fun') arrs liftIdentityMapping _ _ _ _ = cannotSimplify++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 = 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 _ _ _ _ = cannotSimplify -- | Remove all arguments to the map that are simply replicates. -- These can be turned into free variables instead.
src/Futhark/Test.hs view
@@ -21,12 +21,15 @@ , TestRun (..) , ExpectedResult (..) , Values (..)+ , GenValue (..) , Value ) where import Control.Applicative import qualified Data.ByteString.Lazy as BS+import qualified Data.ByteString as SBS+import Control.Exception (catch) import Control.Monad import Control.Monad.IO.Class import qualified Data.Map.Strict as M@@ -34,6 +37,7 @@ import Data.Functor import Data.Maybe import Data.Foldable (foldl')+import Data.List import Data.Semigroup import qualified Data.Text as T import qualified Data.Text.IO as T@@ -47,13 +51,20 @@ import Text.Megaparsec hiding (many, some) import Text.Megaparsec.Char import Text.Regex.TDFA+import System.Directory+import System.Exit+import System.Process.ByteString (readProcessWithExitCode)+import System.IO (withFile, IOMode(..), hFileSize)+import System.IO.Error import Prelude import Futhark.Analysis.Metrics-import Futhark.Util.Pretty (pretty, prettyText)+import Futhark.Representation.Primitive (IntType(..), FloatType(..), intByteSize, floatByteSize) import Futhark.Test.Values import Futhark.Util (directoryContents)+import Futhark.Util.Pretty (pretty, prettyText)+import Language.Futhark.Syntax (PrimType(..), Int32) -- | Description of a test to be carried out on a Futhark program. -- The Futhark program is stored separately.@@ -115,11 +126,28 @@ } deriving (Show) --- | Several Values - either literally, or by reference to a file.+-- | Several Values - either literally, or by reference to a file, or+-- to be generated on demand. data Values = Values [Value] | InFile FilePath+ | GenValues [GenValue] deriving (Show) +data GenValue = GenValue [Int] PrimType+ -- ^ Generate a value of the given rank and primitive+ -- type. Scalars are considered 0-ary arrays.+ | GenInt Int32+ -- ^ A fixed non-randomised integer.+ deriving (Show)++-- | A prettyprinted representation of type of value produced by a+-- 'GenValue'.+genValueType :: GenValue -> String+genValueType (GenValue ds t) =+ concatMap (\d -> "[" ++ show d ++ "]") ds ++ pretty t+genValueType (GenInt x) =+ show x ++ "i32"+ -- | How a test case is expected to terminate. data ExpectedResult values = Succeeds (Maybe values) -- ^ Execution suceeds, with or without@@ -159,9 +187,11 @@ parseTags :: Parser [T.Text] parseTags = lexstr "tags" *> braces (many parseTag) <|> pure []- where parseTag = T.pack <$> lexeme (some $ satisfy constituent)- constituent c = not (isSpace c) && c /= '}'+ where parseTag = T.pack <$> lexeme (some $ satisfy tagConstituent) +tagConstituent :: Char -> Bool+tagConstituent c = isAlphaNum c || c == '_' || c == '-'+ parseAction :: Parser TestAction parseAction = CompileTimeFailure <$> (lexstr "error:" *> parseExpectedError) <|> (RunCases <$> parseInputOutputs <*>@@ -180,7 +210,7 @@ parseRunTags :: Parser [String] parseRunTags = many parseTag- where parseTag = try $ lexeme $ do s <- some $ satisfy isAlphaNum+ where parseTag = try $ lexeme $ do s <- some $ satisfy tagConstituent guard $ s `notElem` ["input", "structure", "warning"] return s @@ -190,7 +220,8 @@ <|> pure [] parseRunCase i = do tags <- parseRunTags- input <- parseInput+ lexstr "input"+ input <- if "random" `elem` tags then parseRandomValues else parseValues expr <- parseExpectedResult return $ TestRun tags input expr i $ desc i input @@ -208,7 +239,8 @@ where vs' = case unwords (map pretty vs) of s | length s > 50 -> take 50 s ++ "..." | otherwise -> s-+ desc _ (GenValues gens) =+ unwords $ map genValueType gens parseExpectedResult :: Parser (ExpectedResult Values) parseExpectedResult =@@ -225,12 +257,34 @@ -- newlines like ordinary characters, which is what we want. else ThisError s <$> makeRegexOptsM blankCompOpt defaultExecOpt (T.unpack s) -parseInput :: Parser Values-parseInput = lexstr "input" *> parseValues+parseRandomValues :: Parser Values+parseRandomValues = GenValues <$> between (lexstr "{") (lexstr "}") (many parseGenValue) +parseGenValue :: Parser GenValue+parseGenValue = choice [ GenValue <$> many dim <*> parsePrimType+ , lexeme $ GenInt . read <$> some (satisfy isDigit)+ ]+ where dim = between (lexstr "[") (lexstr "]") $+ lexeme $ read <$> some (satisfy isDigit)++parsePrimType :: Parser PrimType+parsePrimType =+ choice [ lexstr "i8" $> Signed Int8+ , lexstr "i16" $> Signed Int16+ , lexstr "i32" $> Signed Int32+ , lexstr "i64" $> Signed Int64+ , lexstr "u8" $> Unsigned Int8+ , lexstr "u16" $> Unsigned Int16+ , lexstr "u32" $> Unsigned Int32+ , lexstr "u64" $> Unsigned Int64+ , lexstr "f32" $> FloatType Float32+ , lexstr "f64" $> FloatType Float64+ , lexstr "bool" $> Bool+ ]+ parseValues :: Parser Values parseValues = do s <- parseBlock- case valuesFromByteString "input" $ BS.fromStrict $ T.encodeUtf8 s of+ case valuesFromByteString "input block contents" $ BS.fromStrict $ T.encodeUtf8 s of Left err -> fail err Right vs -> return $ Values vs <|> lexstr "@" *> lexeme (InFile . T.unpack <$> nextWord)@@ -380,12 +434,11 @@ getValues :: MonadIO m => FilePath -> Values -> m [Value] getValues _ (Values vs) = return vs-getValues dir (InFile file) = do- s <- getValuesBS dir (InFile file)- case valuesFromByteString file' s of+getValues dir v = do+ s <- getValuesBS dir v+ case valuesFromByteString "file" s of Left e -> fail $ show e Right vs -> return vs- where file' = dir </> file -- | Extract a pretty representation of some 'Values'. In the IO -- monad because this might involve reading from a file. There is no@@ -405,3 +458,46 @@ where file' = dir </> file readAndDecompress = do s <- BS.readFile file' E.evaluate $ decompress s+getValuesBS dir (GenValues gens) =+ mconcat <$> mapM (getGenBS dir) gens++getGenBS :: MonadIO m => FilePath -> GenValue -> m BS.ByteString+getGenBS dir gen = do+ exists_and_proper_size <- liftIO $+ withFile (dir </> file) ReadMode (fmap (== genFileSize gen) . hFileSize)+ `catch` \ex -> if isDoesNotExistError ex then return False+ else E.throw ex+ unless exists_and_proper_size $ liftIO $ do+ s <- genValues [gen]+ createDirectoryIfMissing True $ takeDirectory $ dir </> file+ SBS.writeFile (dir </> file) s+ getValuesBS dir $ InFile file+ where file = "data" </> genFileName gen++genValues :: [GenValue] -> IO SBS.ByteString+genValues gens = do+ (code, stdout, stderr) <- readProcessWithExitCode "futhark-dataset" args mempty+ case code of+ ExitSuccess ->+ return stdout+ ExitFailure e ->+ fail $ "futhark-dataset failed with exit code " ++ show e ++ " and stderr:\n" +++ map (chr . fromIntegral) (SBS.unpack stderr)+ where args = "-b" : concatMap argForGen gens+ argForGen g = ["-g", genValueType g]++genFileName :: GenValue -> FilePath+genFileName gen = genValueType gen ++ ".in"++-- | Compute the expected size of the file. We use this to check+-- whether an existing file is broken/truncated.+genFileSize :: GenValue -> Integer+genFileSize = genSize+ where header_size = 1 + 1 + 1 + 4 -- 'b' <version> <num_dims> <type>+ genSize (GenValue ds t) = header_size + toInteger (length ds) * 8 ++ product (map toInteger ds) * primSize t+ genSize (GenInt _) = header_size + primSize (Signed Int32)+ primSize (Signed it) = intByteSize it+ primSize (Unsigned it) = intByteSize it+ primSize (FloatType ft) = floatByteSize ft+ primSize Bool = 1
src/Futhark/Test/Values.hs view
@@ -6,12 +6,15 @@ -- here does not support tuples, so don't use those as input/output -- for your test programs. module Futhark.Test.Values- ( Value- , valueType+ ( Value(..) -- * Reading Values , readValues + -- * Types of values+ , ValueType(..)+ , valueType+ -- * Comparing Values , compareValues , Mismatch@@ -74,13 +77,13 @@ put (Int16Value shape vs) = putBinaryValue " i16" shape vs putInt16le put (Int32Value shape vs) = putBinaryValue " i32" shape vs putInt32le put (Int64Value shape vs) = putBinaryValue " i64" shape vs putInt64le- put (Word8Value shape vs) = putBinaryValue " i8" shape vs putWord8- put (Word16Value shape vs) = putBinaryValue " i16" shape vs putWord16le- put (Word32Value shape vs) = putBinaryValue " i32" shape vs putWord32le- put (Word64Value shape vs) = putBinaryValue " i64" shape vs putWord64le+ put (Word8Value shape vs) = putBinaryValue " u8" shape vs putWord8+ 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 (BoolValue shape vs) = putBinaryValue " f64" shape vs $ putInt8 . boolToInt+ put (BoolValue shape vs) = putBinaryValue "bool" shape vs $ putInt8 . boolToInt where boolToInt True = 1 boolToInt False = 0 @@ -133,7 +136,7 @@ instance PP.Pretty Value where ppr v | product (valueShape v) == 0 = text "empty" <>- parens (dims <> text (valueElemType v))+ parens (dims <> ppr (valueElemType v)) where dims = mconcat $ replicate (length (valueShape v)-1) $ text "[]" ppr (Int8Value shape vs) = pprArray (UVec.toList shape) vs ppr (Int16Value shape vs) = pprArray (UVec.toList shape) vs@@ -155,24 +158,31 @@ where slice_size = product ds slice i = UVec.slice (i*slice_size) slice_size vs +-- | A representation of the simple values we represent in this module.+data ValueType = ValueType [Int] F.PrimType+ deriving (Show)++instance PP.Pretty ValueType where+ ppr (ValueType ds t) = mconcat (map pprDim ds) <> ppr t+ where pprDim d = brackets $ ppr d+ -- | A textual description of the type of a value. Follows Futhark -- type notation, and contains the exact dimension sizes if an array.-valueType :: Value -> String-valueType v = concatMap (\d -> "[" ++ show d ++ "]") (valueShape v) ++- valueElemType v+valueType :: Value -> ValueType+valueType v = ValueType (valueShape v) $ valueElemType v -valueElemType :: Value -> String-valueElemType (Int8Value _ _) = "i8"-valueElemType (Int16Value _ _) = "i16"-valueElemType (Int32Value _ _) = "i32"-valueElemType (Int64Value _ _) = "i64"-valueElemType (Word8Value _ _) = "u8"-valueElemType (Word16Value _ _) = "u16"-valueElemType (Word32Value _ _) = "u32"-valueElemType (Word64Value _ _) = "u64"-valueElemType (Float32Value _ _) = "f32"-valueElemType (Float64Value _ _) = "f64"-valueElemType (BoolValue _ _) = "bool"+valueElemType :: Value -> F.PrimType+valueElemType Int8Value{} = F.Signed F.Int8+valueElemType Int16Value{} = F.Signed F.Int16+valueElemType Int32Value{} = F.Signed F.Int32+valueElemType Int64Value{} = F.Signed F.Int64+valueElemType Word8Value{} = F.Unsigned F.Int8+valueElemType Word16Value{} = F.Unsigned F.Int16+valueElemType Word32Value{} = F.Unsigned F.Int32+valueElemType Word64Value{} = F.Unsigned F.Int64+valueElemType Float32Value{} = F.FloatType F.Float32+valueElemType Float64Value{} = F.FloatType F.Float64+valueElemType BoolValue{} = F.Bool valueShape :: Value -> [Int] valueShape (Int8Value shape _) = UVec.toList shape@@ -348,15 +358,15 @@ readFloat32 :: ReadValue Float readFloat32 = readFloat lexFloat32 where lexFloat32 [F32LIT x] = Just x- lexFloat32 [ID "f32", DOT, ID "inf"] = Just $ 1/0- lexFloat32 [ID "f32", DOT, ID "nan"] = Just $ 0/0+ lexFloat32 [ID "f32", PROJ_FIELD "inf"] = Just $ 1/0+ lexFloat32 [ID "f32", PROJ_FIELD "nan"] = Just $ 0/0 lexFloat32 _ = Nothing readFloat64 :: ReadValue Double readFloat64 = readFloat lexFloat64 where lexFloat64 [F64LIT x] = Just x- lexFloat64 [ID "f64", DOT, ID "inf"] = Just $ 1/0- lexFloat64 [ID "f64", DOT, ID "nan"] = Just $ 0/0+ lexFloat64 [ID "f64", PROJ_FIELD "inf"] = Just $ 1/0+ lexFloat64 [ID "f64", PROJ_FIELD "nan"] = Just $ 0/0 lexFloat64 _ = Nothing readBool :: ReadValue Bool@@ -504,7 +514,7 @@ (BoolValue _ got_vs, BoolValue _ expected_vs) -> compareGen compareBool got_vs expected_vs _ ->- Just $ TypeMismatch i (valueElemType got_v) (valueElemType expected_v)+ Just $ TypeMismatch i (pretty $ valueElemType got_v) (pretty $ valueElemType expected_v) | otherwise = Just $ ArrayShapeMismatch i (valueShape got_v) (valueShape expected_v) where compareNum tol = compareGen $ compareElement tol
src/Futhark/Tools.hs view
@@ -159,16 +159,12 @@ -- The number of results in the body matches exactly the size (and -- order) of 'pat', so we bind them up here, again with a reshape to- -- make the types work out. We also do a copy to ensure that the- -- result does not have any aliases (as the semantics of Stream- -- require).+ -- make the types work out. forM_ (zip (patternElements pat) $ bodyResult $ lambdaBody lam) $ \(pe, se) -> case (arrayDims $ patElemType pe, se) of (dims, Var v)- | not $ null dims -> do- v_reshaped <- letExp (baseString v <> "_reshaped") $- BasicOp $ Reshape (map DimCoercion dims) v- letBindNames_ [patElemName pe] $ BasicOp $ Copy v_reshaped+ | not $ null dims ->+ letBindNames_ [patElemName pe] $ BasicOp $ Reshape (map DimCoercion dims) v _ -> letBindNames_ [patElemName pe] $ BasicOp $ SubExp se partitionChunkedFoldParameters :: Int -> [Param attr]
src/Futhark/TypeCheck.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, TypeFamilies, ScopedTypeVariables #-}+{-# LANGUAGE DefaultSignatures #-} -- | The type checker checks whether the program is type-consistent. module Futhark.TypeCheck ( -- * Interface@@ -12,6 +13,7 @@ , context , message , Checkable (..)+ , CheckableOp (..) , lookupVar , lookupAliases , Occurences@@ -780,17 +782,6 @@ checkBasicOp (Assert e _ _) = require [Prim Bool] e -checkBasicOp (Partition _ flags arrs) = do- flagst <- lookupType flags- unless (rowType flagst == Prim int32) $- bad $ TypeError $ "Flag array has type " ++ pretty flagst ++ "."- forM_ arrs $ \arr -> do- arrt <- lookupType arr- unless (arrayRank arrt > 0) $- bad $ TypeError $- "Array argument " ++ pretty arr ++- " to partition has type " ++ pretty arrt ++ "."- checkExp :: Checkable lore => Exp (Aliases lore) -> TypeM lore () @@ -1082,17 +1073,48 @@ unless (primExpType e == t) $ bad $ TypeError $ pretty e ++ " must have type " ++ pretty t +class Attributes lore => CheckableOp lore where+ checkOp :: OpWithAliases (Op lore) -> TypeM lore ()+ -- | The class of lores that can be type-checked.-class (Attributes lore, CanBeAliased (Op lore)) => Checkable lore where+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 () checkRetType :: [RetType lore] -> TypeM lore ()- checkOp :: OpWithAliases (Op lore) -> TypeM lore () matchPattern :: Pattern (Aliases lore) -> Exp (Aliases lore) -> TypeM lore () primFParam :: VName -> PrimType -> TypeM lore (FParam (Aliases lore))- primLParam :: VName -> PrimType -> TypeM lore (LParam (Aliases lore)) matchReturnType :: [RetType lore] -> Result -> TypeM lore () matchBranchType :: [BranchType lore] -> Body (Aliases lore) -> TypeM lore ()++ default checkExpLore :: ExpAttr lore ~ () => ExpAttr lore -> TypeM lore ()+ checkExpLore = return++ default checkBodyLore :: BodyAttr lore ~ () => BodyAttr lore -> TypeM lore ()+ checkBodyLore = return++ default checkFParamLore :: FParamAttr lore ~ DeclType => VName -> FParamAttr lore -> TypeM lore ()+ checkFParamLore _ = checkType++ default checkLParamLore :: LParamAttr lore ~ Type => VName -> LParamAttr lore -> TypeM lore ()+ checkLParamLore _ = checkType++ default checkLetBoundLore :: LetAttr lore ~ Type => VName -> LetAttr lore -> TypeM lore ()+ checkLetBoundLore _ = checkType++ default checkRetType :: RetType lore ~ DeclExtType => [RetType lore] -> TypeM lore ()+ checkRetType = mapM_ checkExtType . retTypeValues++ 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))+ primFParam name t = return $ Param name (Prim t)++ default matchReturnType :: RetType lore ~ DeclExtType => [RetType lore] -> Result -> TypeM lore ()+ matchReturnType = matchExtReturnType . map fromDecl++ default matchBranchType :: BranchType lore ~ ExtType => [BranchType lore] -> Body (Aliases lore) -> TypeM lore ()+ matchBranchType = matchExtBranchType
src/Language/Futhark.hs view
@@ -9,7 +9,7 @@ , ValBind, Dec, Spec, Prog , TypeBind, TypeDecl , StructTypeArg, ArrayElemType- , TypeParam+ , TypeParam, Case ) where @@ -71,3 +71,6 @@ -- | A known array element type with no shape annotations, but aliasing -- information. type ArrayElemType = ArrayElemTypeBase () Names++-- | A type-checked case (of a match expression).+type Case = CaseBase Info VName
src/Language/Futhark/Attributes.hs view
@@ -29,6 +29,7 @@ , patIdentSet , patternType , patternStructType+ , patternPatternType , patternParam , patternNoShapeAnnotations , patternOrderZero@@ -94,6 +95,7 @@ , UncheckedValBind , UncheckedDec , UncheckedProg+ , UncheckedCase ) where @@ -136,12 +138,14 @@ Prim{} -> mempty TypeVar _ _ _ targs -> concatMap typeArgDims targs Arrow _ v t1 t2 -> filter (notV v) $ nestedDims t1 <> nestedDims t2+ Enum{} -> [] where arrayNestedDims ArrayPrimElem{} = mempty arrayNestedDims (ArrayPolyElem _ targs _) = concatMap typeArgDims targs arrayNestedDims (ArrayRecordElem ts) = fold (fmap recordArrayElemNestedDims ts)+ arrayNestedDims ArrayEnumElem{} = mempty recordArrayElemNestedDims (RecordArrayArrayElem a ds _) = arrayNestedDims a <> shapeDims ds@@ -202,6 +206,7 @@ diet (Arrow _ _ t1 t2) = FuncDiet (diet t1) (diet t2) diet (Array _ _ Unique) = Consume diet (Array _ _ Nonunique) = Observe+diet (Enum _) = Observe -- | @t `maskAliases` d@ removes aliases (sets them to 'mempty') from -- the parts of @t@ that are denoted as 'Consumed' by the 'Diet' @d@.@@ -249,7 +254,11 @@ where asType (RecordArrayElem (ArrayPrimElem bt _)) = Prim bt asType (RecordArrayElem (ArrayPolyElem bt targs als)) = TypeVar als u bt targs asType (RecordArrayElem (ArrayRecordElem ts')) = Record $ fmap asType ts'+ asType (RecordArrayElem (ArrayEnumElem cs _)) = Enum cs asType (RecordArrayArrayElem et e_shape _) = Array et e_shape u+peelArray n (Array (ArrayEnumElem cs _) shape _)+ | shapeRank shape == n =+ Just $ Enum cs peelArray n (Array et shape u) = do shape' <- stripDims n shape return $ Array et shape' u@@ -291,6 +300,8 @@ ts' <- traverse (typeToRecordArrayElem' as) ts return $ Array (ArrayRecordElem ts') shape u arrayOfWithAliases Arrow{} _ _ _ = Nothing+arrayOfWithAliases (Enum cs) as shape u =+ Just $ Array (ArrayEnumElem cs as) shape u typeToRecordArrayElem :: Monoid as => TypeBase dim as@@ -310,6 +321,8 @@ typeToRecordArrayElem' _ (Array et shape u) = Just $ RecordArrayArrayElem et shape u typeToRecordArrayElem' _ Arrow{} = Nothing+typeToRecordArrayElem' as (Enum cs) =+ Just $ RecordArrayElem $ ArrayEnumElem cs as recordArrayElemToType :: Monoid as => RecordArrayElemTypeBase dim as@@ -323,6 +336,7 @@ arrayElemToType (ArrayRecordElem ts) = let ts' = fmap recordArrayElemToType ts in (Record $ fmap fst ts', foldMap snd ts')+arrayElemToType (ArrayEnumElem cs als) = (Enum cs, als) -- | @stripArray n t@ removes the @n@ outermost layers of the array. -- Essentially, it is the type of indexing an array of type @t@ with@@ -392,6 +406,7 @@ RecordArrayElem $ setArrayElemUniqueness et u set (RecordArrayArrayElem et shape e_u) = RecordArrayArrayElem (setArrayElemUniqueness et u) shape e_u+setArrayElemUniqueness (ArrayEnumElem cs as) _ = ArrayEnumElem cs as -- | @t \`setAliases\` als@ returns @t@, but with @als@ substituted for -- any already present aliasing.@@ -493,6 +508,8 @@ removeShapeAnnotations t typeOf (IndexSection _ (Info t) _) = removeShapeAnnotations t+typeOf (VConstr0 _ (Info t) _) = t+typeOf (Match _ _ (Info t) _) = t foldFunType :: Monoid as => [TypeBase dim as] -> TypeBase dim as -> TypeBase dim as foldFunType ps ret = foldr (Arrow mempty Nothing) ret ps@@ -518,6 +535,8 @@ mconcat $ typeVarFree tn : map typeArgFree targs Array (ArrayRecordElem fields) _ _ -> foldMap (typeVars . fst . recordArrayElemToType) fields+ Array ArrayEnumElem{} _ _ -> mempty+ Enum{} -> mempty where typeVarFree = S.singleton . typeLeaf typeArgFree (TypeArgType ta _) = typeVars ta typeArgFree TypeArgDim{} = mempty@@ -544,6 +563,7 @@ returnType (Arrow _ v t1 t2) ds args = Arrow als v (bimap id (const mempty) t1) (returnType t2 ds args) where als = foldMap aliases $ zipWith maskAliases args ds+returnType (Enum cs) _ _ = Enum cs typeArgReturnType :: TypeArg shape () -> [Diet] -> [CompType] -> TypeArg shape Names@@ -564,6 +584,9 @@ where als = mconcat $ map aliases $ zipWith maskAliases args ds arrayElemReturnType (ArrayRecordElem et) ds args = ArrayRecordElem $ fmap (\t -> recordArrayElemReturnType t ds args) et+arrayElemReturnType (ArrayEnumElem cs ()) ds args =+ ArrayEnumElem cs als+ where als = mconcat $ map aliases $ zipWith maskAliases args ds recordArrayElemReturnType :: RecordArrayElemTypeBase dim () -> [Diet]@@ -580,10 +603,12 @@ concreteType TypeVar{} = False concreteType Arrow{} = False concreteType (Record ts) = all concreteType ts+concreteType Enum{} = True concreteType (Array at _ _) = concreteArrayType at where concreteArrayType ArrayPrimElem{} = True concreteArrayType ArrayPolyElem{} = False concreteArrayType (ArrayRecordElem ts) = all concreteRecordArrayElem ts+ concreteArrayType ArrayEnumElem{} = True concreteRecordArrayElem (RecordArrayElem et) = concreteArrayType et concreteRecordArrayElem (RecordArrayArrayElem et _ _) = concreteArrayType et@@ -597,6 +622,7 @@ orderZero (Record fs) = all orderZero $ M.elems fs orderZero TypeVar{} = True orderZero Arrow{} = False+orderZero Enum{} = True -- | Extract all the shape names that occur in a given pattern. patternDimNames :: PatternBase Info VName -> Names@@ -607,6 +633,7 @@ patternDimNames (Wildcard (Info tp) _) = typeDimNames tp patternDimNames (PatternAscription p (TypeDecl _ (Info t)) _) = patternDimNames p <> typeDimNames t+patternDimNames (PatternLit _ (Info tp) _) = typeDimNames tp -- | Extract all the shape names that occur in a given type. typeDimNames :: TypeBase (DimDecl VName) als -> Names@@ -625,15 +652,17 @@ Id _ (Info t) _ -> orderZero t Wildcard (Info t) _ -> orderZero t PatternAscription p _ _ -> patternOrderZero p+ PatternLit _ (Info t) _ -> orderZero t -- | The set of identifiers bound in a pattern. patIdentSet :: (Functor f, Ord vn) => PatternBase f vn -> S.Set (IdentBase f vn)-patIdentSet (Id v t loc) = S.singleton $ Ident v (removeShapeAnnotations <$> t) loc+patIdentSet (Id v t loc) = S.singleton $ Ident v (removeShapeAnnotations <$> t) loc patIdentSet (PatternParens p _) = patIdentSet p patIdentSet (TuplePattern pats _) = mconcat $ map patIdentSet pats patIdentSet (RecordPattern fs _) = mconcat $ map (patIdentSet . snd) fs patIdentSet Wildcard{} = mempty patIdentSet (PatternAscription p _ _) = patIdentSet p+patIdentSet PatternLit{} = mempty -- | The type of values bound by the pattern. patternType :: PatternBase Info VName -> CompType@@ -643,15 +672,21 @@ patternType (TuplePattern pats _) = tupleRecord $ map patternType pats patternType (RecordPattern fs _) = Record $ patternType <$> M.fromList fs patternType (PatternAscription p _ _) = patternType p+patternType (PatternLit _ (Info t) _) = removeShapeAnnotations t +-- | The type of a pattern, including shape annotations.+patternPatternType :: PatternBase Info VName -> PatternType+patternPatternType (Wildcard (Info t) _) = t+patternPatternType (PatternParens p _) = patternPatternType p+patternPatternType (Id _ (Info t) _) = t+patternPatternType (TuplePattern pats _) = tupleRecord $ map patternPatternType pats+patternPatternType (RecordPattern fs _) = Record $ patternPatternType <$> M.fromList fs+patternPatternType (PatternAscription p _ _) = patternPatternType p+patternPatternType (PatternLit _ (Info t) _) = t+ -- | The type matched by the pattern, including shape declarations if present. patternStructType :: PatternBase Info VName -> StructType-patternStructType (PatternAscription p _ _) = patternStructType p-patternStructType (PatternParens p _) = patternStructType p-patternStructType (Id _ (Info t) _) = t `setAliases` ()-patternStructType (TuplePattern ps _) = tupleRecord $ map patternStructType ps-patternStructType (RecordPattern fs _) = Record $ patternStructType <$> M.fromList fs-patternStructType (Wildcard (Info t) _) = vacuousShapeAnnotations $ toStruct t+patternStructType = toStruct . patternPatternType -- | When viewed as a function parameter, does this pattern correspond -- to a named parameter of some type?@@ -679,6 +714,8 @@ RecordPattern (map (fmap patternNoShapeAnnotations) ps) loc patternNoShapeAnnotations (Wildcard (Info t) loc) = Wildcard (Info (vacuousShapeAnnotations t)) loc+patternNoShapeAnnotations (PatternLit e (Info t) loc) =+ PatternLit e (Info (vacuousShapeAnnotations t)) loc -- | Names of primitive types to types. This is only valid if no -- shadowing is going on, but useful for tools.@@ -914,12 +951,13 @@ -- | The modules imported by a single declaration. decImports :: DecBase f vn -> [(String,SrcLoc)]-decImports (OpenDec x _ _) = modExpImports x+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{} = []@@ -934,13 +972,14 @@ -- declaration. progModuleTypes :: Ord vn => ProgBase f vn -> S.Set vn progModuleTypes = mconcat . map onDec . progDecs- where onDec (OpenDec x _ _) = onModExp x+ 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 LocalDec{} = mempty+ onDec ImportDec{} = mempty onModExp ModVar{} = mempty onModExp (ModParens p _) = onModExp p@@ -1035,3 +1074,6 @@ -- | 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
src/Language/Futhark/Interpreter.hs view
@@ -17,6 +17,7 @@ , isEmptyArray ) where +import Control.Monad.Trans.Maybe import Control.Monad.Free.Church import Control.Monad.Except import Control.Monad.Reader@@ -88,11 +89,13 @@ | ValueArray !(Array Int Value) | ValueRecord (M.Map Name Value) | ValueFun (Value -> EvalM Value)+ | ValueEnum Name instance Eq Value where ValuePrim x == ValuePrim y = x == y ValueArray x == ValueArray y = x == y ValueRecord x == ValueRecord y = x == y+ ValueEnum x == ValueEnum y = x == y _ == _ = False prettyRecord :: Pretty a => M.Map Name a -> Doc@@ -115,6 +118,7 @@ ppr (ValueRecord m) = prettyRecord m ppr ValueFun{} = text "#<fun>"+ ppr (ValueEnum n) = text "#" <> ppr n -- | Create an array value; failing if that would result in an -- irregular array.@@ -287,30 +291,43 @@ matchPattern :: Env -> Pattern -> Value -> EvalM (M.Map VName (Maybe T.BoundV, Value))-matchPattern env = matchPattern' env mempty+matchPattern env p v = do+ m <- runMaybeT $ patternMatch env mempty p v+ case m of+ Nothing -> error $ "matchPattern: missing case for " ++ pretty p ++ " and " ++ pretty v+ Just binds -> return binds -matchPattern' :: Env -> M.Map VName (Maybe T.BoundV, Value)- -> Pattern -> Value- -> EvalM (M.Map VName (Maybe T.BoundV, Value))-matchPattern' _ m (Id v (Info t) _) val =- pure $ M.insert v (Just $ T.BoundV [] $ toStruct t, val) m-matchPattern' env m (PatternParens p _) val =- matchPattern' env m p val-matchPattern' env m (TuplePattern ps _) (ValueRecord vs) =- foldM (\m' (p,v) -> matchPattern' env m' p v) m $- zip ps (map snd $ sortFields vs)-matchPattern' env m (RecordPattern ps _) (ValueRecord vs) =- foldM (\m' (p,v) -> matchPattern' env m' p v) m $- zip (map snd $ sortFields $ M.fromList ps) (map snd $ sortFields vs)-matchPattern' _ m Wildcard{} _ = pure m-matchPattern' env m (PatternAscription pat td loc) v = do- t <- evalType env $ unInfo $ expandedType td+patternMatch :: Env -> M.Map VName (Maybe T.BoundV, Value)+ -> Pattern -> Value+ -> MaybeT EvalM (M.Map VName (Maybe T.BoundV, Value))+patternMatch _ m (Id v (Info t) _) val =+ lift $ pure $ M.insert v (Just $ T.BoundV [] $ toStruct t, val) m+patternMatch _ m Wildcard{} _ =+ lift $ pure m+patternMatch env m (TuplePattern ps _) (ValueRecord vs)+ | length ps == length vs' =+ foldM (\m' (p,v) -> patternMatch env m' p v) m $+ zip ps (map snd $ sortFields vs)+ where vs' = sortFields vs+patternMatch env m (RecordPattern ps _) (ValueRecord vs)+ | length ps == length vs' =+ foldM (\m' (p,v) -> patternMatch env m' p v) m $+ zip (map snd $ sortFields $ M.fromList ps) (map snd $ sortFields vs)+ where vs' = sortFields vs+patternMatch env m (PatternParens p _) v = patternMatch env m p v+patternMatch env m (PatternAscription p td loc) v = do+ t <- lift $ evalType env $ unInfo $ expandedType td case matchValueToType env m t v of- Left err -> bad loc env err- Right m' -> matchPattern' env m' pat v-matchPattern' _ _ pat v =- error $ "matchPattern': missing case for " ++ pretty pat ++ " and " ++ pretty v+ Left err -> lift $ bad loc env err+ Right m' -> patternMatch env m' p v+patternMatch env m (PatternLit e _ _) v = do+ v' <- lift $ eval env e+ if v == v'+ then pure m+ else mzero +patternMatch _ _ _ _ = mzero+ -- | For matching size annotations (the actual type will have been -- verified by the type checker). It is assumed that previously -- unbound names are in binding position here.@@ -511,6 +528,7 @@ t'' <- evalType env t' return (mempty, M.singleton p $ T.TypeAbbr l [] t'') matchPtoA _ _ = return mempty+evalType _ (Enum cs) = return $ Enum cs eval :: Env -> Exp -> EvalM Value @@ -717,7 +735,7 @@ zero = (`P.doMul` Int64Value 0) forLoop iv bound i v- | i == bound = return v+ | i >= bound = return v | otherwise = do env' <- withLoopParams v forLoop iv bound (inc i) =<<@@ -749,8 +767,27 @@ unless cond $ bad loc env s eval env e +eval _ (VConstr0 c _ _) = return $ ValueEnum c++eval env (Match e cs _ _) = do+ v <- eval env e+ match v cs+ where match v [] =+ fail "Pattern match failure."+ match v (c:cs) = do+ c' <- evalCase v env c+ case c' of+ Just v' -> return v'+ Nothing -> match v cs+ eval _ e = error $ "eval not yet: " ++ show e +evalCase :: Value -> Env -> CaseBase Info VName+ -> EvalM (Maybe Value)+evalCase v env (CasePat p cExp _) = runMaybeT $ do+ pEnv <- valEnv <$> patternMatch env mempty p v+ lift $ eval (pEnv <> env) cExp+ substituteInModule :: M.Map VName VName -> Module -> Module substituteInModule substs = onModule where@@ -821,9 +858,12 @@ val <- eval env $ Lambda tps ps def Nothing (Info (mempty, t')) loc return $ valEnv (M.singleton v (Just ftype, val)) <> env -evalDec env (OpenDec me (Info _) _) = do+evalDec env (OpenDec me _) = do Module me' <- evalModExp env me return $ me' <> env++evalDec env (ImportDec name name' loc) =+ evalDec env $ LocalDec (OpenDec (ModImport name name' loc) loc) loc evalDec env (LocalDec d _) = evalDec env d evalDec env SigDec{} = return env
src/Language/Futhark/Parser/Lexer.x view
@@ -76,14 +76,11 @@ "," { tokenC COMMA } "_" { tokenC UNDERSCORE } "->" { tokenC RIGHT_ARROW }- "<-" { tokenC LEFT_ARROW } ":" { tokenC COLON }- "." { tokenC DOT } "\" { tokenC BACKSLASH } "'" { tokenC APOSTROPHE } "'^" { tokenC APOSTROPHE_THEN_HAT } "`" { tokenC BACKTICK }- "#" { tokenC HASH } "..<" { tokenC TWO_DOTS_LT } "..>" { tokenC TWO_DOTS_GT } "..." { tokenC THREE_DOTS }@@ -113,12 +110,16 @@ @qualidentifier "[" { tokenM $ fmap (uncurry QUALINDEXING) . mkQualId . T.takeWhile (/='[') } @identifier "." "(" { tokenM $ fmap (QUALPAREN []) . indexing . T.init . T.takeWhile (/='(') } @qualidentifier "." "(" { tokenM $ fmap (uncurry QUALPAREN) . mkQualId . T.init . T.takeWhile (/='(') }+ "#" @identifier { tokenS $ CONSTRUCTOR . nameFromText . T.drop 1 } @unop { tokenS $ UNOP . nameFromText } @qualunop { tokenM $ fmap (uncurry QUALUNOP) . mkQualId } @binop { tokenM $ return . symbol [] . nameFromText } @qualbinop { tokenM $ \s -> do (qs,k) <- mkQualId s; return (symbol qs k) }++ "." (@identifier|[0-9]+) { tokenM $ return . PROJ_FIELD . nameFromText . T.drop 1 }+ "." "[" { tokenC PROJ_INDEX } { keyword :: T.Text -> Token@@ -146,6 +147,8 @@ "while" -> WHILE "unsafe" -> UNSAFE "assert" -> ASSERT+ "match" -> MATCH+ "case" -> CASE _ -> ID $ nameFromText s @@ -215,6 +218,7 @@ | nameToText q == "-" = NEGATE | nameToText q == "<" = LTH | nameToText q == "^" = HAT+ | nameToText q == "|" = PIPE | otherwise = SYMBOL (leadingOperator q) [] q symbol qs q = SYMBOL (leadingOperator q) qs q @@ -295,6 +299,9 @@ | UNOP Name | QUALUNOP [Name] Name | SYMBOL BinOp [Name] Name+ | CONSTRUCTOR Name+ | PROJ_FIELD Name+ | PROJ_INDEX | INTLIT Integer | STRINGLIT String@@ -316,8 +323,6 @@ | APOSTROPHE | APOSTROPHE_THEN_HAT | BACKTICK- | HASH- | DOT | TWO_DOTS | TWO_DOTS_LT | TWO_DOTS_GT@@ -332,13 +337,13 @@ | COMMA | UNDERSCORE | RIGHT_ARROW- | LEFT_ARROW | EQU | ASTERISK | NEGATE | LTH | HAT+ | PIPE | IF | THEN@@ -362,6 +367,8 @@ | VAL | OPEN | LOCAL+ | MATCH+ | CASE | DOC String
src/Language/Futhark/Parser/Parser.y view
@@ -56,6 +56,8 @@ let { L $$ LET } loop { L $$ LOOP } in { L $$ IN }+ match { L $$ MATCH }+ case { L $$ CASE } id { L _ (ID _) } 'id[' { L _ (INDEXING _) }@@ -67,6 +69,11 @@ unop { L _ (UNOP _) } qunop { L _ (QUALUNOP _ _) } + constructor { L _ (CONSTRUCTOR _) }++ '.field' { L _ (PROJ_FIELD _) }+ '.[' { L _ PROJ_INDEX }+ intlit { L _ (INTLIT _) } i8lit { L _ (I8LIT _) } i16lit { L _ (I16LIT _) }@@ -82,7 +89,6 @@ stringlit { L _ (STRINGLIT _) } charlit { L _ (CHARLIT _) } - '#' { L $$ HASH } '..' { L $$ TWO_DOTS } '...' { L $$ THREE_DOTS } '..<' { L $$ TWO_DOTS_LT }@@ -93,6 +99,7 @@ '-' { L $$ NEGATE } '<' { L $$ LTH } '^' { L $$ HAT }+ '|' { L $$ PIPE } '+...' { L _ (SYMBOL Plus _ _) } '-...' { L _ (SYMBOL Minus _ _) }@@ -133,9 +140,7 @@ '`' { L $$ BACKTICK } entry { L $$ ENTRY } '->' { L $$ RIGHT_ARROW }- '<-' { L $$ LEFT_ARROW } ':' { L $$ COLON }- '.' { L $$ DOT } for { L $$ FOR } do { L $$ DO } with { L $$ WITH }@@ -154,20 +159,20 @@ doc { L _ (DOC _) } %left bottom-%left ifprec letprec unsafe-%left ','+%left ifprec letprec unsafe caseprec typeprec enumprec+%left ',' case %left ':' %right '...' '..<' '..>' '..' %left '`' %right '->' %left with-%left '=' '<-'+%left '=' %left '|>...' %right '<|...' %left '||...' %left '&&...' %left '<=...' '>=...' '>...' '<' '<...' '==...' '!=...'-%left '&...' '^...' '^' '|...'+%left '&...' '^...' '^' '|...' '|' %left '<<...' '>>...' %left '+...' '-...' '-' %left '*...' '*' '/...' '%...' '//...' '%%...'@@ -181,7 +186,7 @@ Doc :: { DocComment } : doc { let L loc (DOC s) = $1 in DocComment s loc } --- Three cases to avoid ambiguities.+-- Four cases to avoid ambiguities. Prog :: { UncheckedProg } -- File begins with a file comment, followed by a Dec with a comment. : Doc Doc Dec_ Decs { Prog (Just $1) (addDoc $2 $3 : $4) }@@ -189,6 +194,8 @@ | Doc Dec_ Decs { Prog (Just $1) ($2 : $3) } -- File begins with a dec with no comment. | Dec_ Decs { Prog Nothing ($1 : $2) }+ -- File is empty.+ | { Prog Nothing [] } ; Dec :: { UncheckedDec }@@ -204,10 +211,9 @@ | TypeAbbr { TypeDec $1 } | SigBind { SigDec $1 } | ModBind { ModDec $1 }- | open ModExp- { OpenDec $2 NoInfo $1 }+ | open ModExp { OpenDec $2 $1 } | import stringlit- { let L loc (STRINGLIT s) = $2 in LocalDec (OpenDec (ModImport s NoInfo loc) NoInfo $1) (srcspan $1 $>) }+ { let L _ (STRINGLIT s) = $2 in ImportDec s NoInfo (srcspan $1 $>) } | local Dec { LocalDec $2 (srcspan $1 $>) } ; @@ -347,6 +353,7 @@ | '^' { qualName (nameFromString "^") } | '&...' { binOpName $1 } | '|...' { binOpName $1 }+ | '|' { qualName (nameFromString "|") } | '>>...' { binOpName $1 } | '<<...' { binOpName $1 } | '<|...' { binOpName $1 }@@ -408,8 +415,7 @@ { let L _ (ID v) = $2 in TEArrow (Just v) $4 $7 (srcspan $1 $>) } | TypeExpTerm '->' TypeExp { TEArrow Nothing $1 $3 (srcspan $1 $>) }- | TypeExpTerm { $1 }-+ | TypeExpTerm %prec typeprec { $1 } TypeExpTerm :: { UncheckedTypeExp } : '*' TypeExpTerm@@ -446,7 +452,17 @@ | '{' '}' { TERecord [] (srcspan $1 $>) } | '{' FieldTypes1 '}' { TERecord $2 (srcspan $1 $>) } | QualName { TEVar (fst $1) (snd $1) }+ | Enum { TEEnum (fst $1) (snd $1)} +Enum :: { ([Name], SrcLoc) }+ : VConstr0 %prec enumprec { ([fst $1], snd $1) }+ | VConstr0 '|' Enum+ { let names = fst $1 : fst $3; loc = srcspan (snd $1) (snd $3)+ in (names, loc) }++VConstr0 :: { (Name, SrcLoc) }+ : constructor { let L _ (CONSTRUCTOR c) = $1 in (c, srclocOf $1) }+ TypeArg :: { TypeArgExp Name } : '[' DimDecl ']' { TypeArgExpDim (fst $2) (srcspan $1 $>) } | '[' ']' { TypeArgExpDim AnyDim (srcspan $1 $>) }@@ -470,13 +486,6 @@ { let L loc (INTLIT n) = $1 in (ConstDim (fromIntegral n), loc) } - -- Errors- | '#' {% parseErrorAt (srclocOf $1) $ Just $- unlines ["found implicit size quantification.",- "This is no longer supported. Use explicit size parameters."]- }-- FunParam :: { PatternBase NoInfo Name } FunParam : InnerPattern { $1 } @@ -515,6 +524,8 @@ | LetExp %prec letprec { $1 } + | MatchExp { $1 }+ | unsafe Exp2 { Unsafe $2 (srcspan $1 $>) } | assert Atom Atom { Assert $2 $3 NoInfo (srcspan $1 $>) } @@ -532,6 +543,7 @@ | Exp2 '<<...' Exp2 { binOp $1 $2 $3 } | Exp2 '&...' Exp2 { binOp $1 $2 $3 } | Exp2 '|...' Exp2 { binOp $1 $2 $3 }+ | Exp2 '|' Exp2 { binOp $1 (L $2 (SYMBOL Bor [] (nameFromString "|"))) $3 } | Exp2 '&&...' Exp2 { binOp $1 $2 $3 } | Exp2 '||...' Exp2 { binOp $1 $2 $3 } | Exp2 '^...' Exp2 { binOp $1 $2 $3 }@@ -565,11 +577,6 @@ | Exp2 with FieldAccesses_ '=' Exp2 { RecordUpdate $1 (map fst $3) $5 NoInfo (srcspan $1 $>) } - | Exp2 with FieldAccesses_ '<-' Exp2- { RecordUpdate $1 (map fst $3) $5 NoInfo (srcspan $1 $>) }- | Exp2 with '[' DimIndices ']' '<-' Exp2- { Update $1 $4 $7 (srcspan $1 $>) }- | '\\' TypeParams FunParams1 maybeAscription(TypeExpTerm) '->' Exp { Lambda $2 (fst $3 : snd $3) $6 (fmap (flip TypeDecl NoInfo) $4) NoInfo (srcspan $1 $>) } @@ -585,6 +592,7 @@ Atom :: { UncheckedExp } Atom : PrimLit { Literal (fst $1) (snd $1) }+ | VConstr0 { VConstr0 (fst $1) NoInfo (snd $1) } | intlit { let L loc (INTLIT x) = $1 in IntLit x NoInfo loc } | floatlit { let L loc (FLOATLIT x) = $1 in FloatLit x NoInfo loc } | stringlit { let L loc (STRINGLIT s) = $1 in@@ -628,8 +636,8 @@ | '(' FieldAccess FieldAccesses ')' { ProjectSection (map fst ($2:$3)) NoInfo (srcspan $1 $>) } - | '(' '.' '[' DimIndices ']' ')'- { IndexSection $4 NoInfo (srcspan $1 $>) }+ | '(' '.[' DimIndices ']' ')'+ { IndexSection $3 NoInfo (srcspan $1 $>) } PrimLit :: { (PrimValue, SrcLoc) }@@ -662,7 +670,7 @@ | Exp { ([], $1) } FieldAccess :: { (Name, SrcLoc) }- : '.' FieldId { (fst $2, srcspan $1 (snd $>)) }+ : '.field' { let L loc (PROJ_FIELD f) = $1 in (f, loc) } FieldAccesses :: { [(Name, SrcLoc)] } : FieldAccess FieldAccesses { $1 : $2 }@@ -700,6 +708,61 @@ LetBody :: { UncheckedExp } : in Exp %prec letprec { $2 } | LetExp %prec letprec { $1 }++MatchExp :: { UncheckedExp }+ : match Exp Cases { let loc = srcspan $1 $>+ in Match $2 $> NoInfo loc }++Cases :: { [CaseBase NoInfo Name] }+ : Case %prec caseprec { [$1] }+ | Case Cases { $1 : $2 }++Case :: { CaseBase NoInfo Name }+ : case CPattern '->' Exp { let loc = srcspan $1 $>+ in CasePat $2 $> loc }++CPattern :: { PatternBase NoInfo Name }+ : CInnerPattern ':' TypeExpDecl { PatternAscription $1 $3 (srcspan $1 $>) }+ | CInnerPattern { $1 }++CPatterns1 :: { [PatternBase NoInfo Name] }+ : CPattern { [$1] }+ | CPattern ',' CPatterns1 { $1 : $3 }++CInnerPattern :: { PatternBase NoInfo Name }+ : id { let L loc (ID name) = $1 in Id name NoInfo loc }+ | '(' BindingBinOp ')' { Id $2 NoInfo (srcspan $1 $>) }+ | '(' BindingUnOp ')' { Id $2 NoInfo (srcspan $1 $>) }+ | '_' { Wildcard NoInfo $1 }+ | '(' ')' { TuplePattern [] (srcspan $1 $>) }+ | '(' CPattern ')' { PatternParens $2 (srcspan $1 $>) }+ | '(' CPattern ',' CPatterns1 ')' { TuplePattern ($2:$4) (srcspan $1 $>) }+ | '{' CFieldPatterns '}' { RecordPattern $2 (srcspan $1 $>) }+ | CaseLiteral { PatternLit (fst $1) NoInfo (snd $1) }++CFieldPattern :: { (Name, PatternBase NoInfo Name) }+ : FieldId '=' CPattern+ { (fst $1, $3) }+ | FieldId ':' TypeExpDecl+ { (fst $1, PatternAscription (Id (fst $1) NoInfo (snd $1)) $3 (srcspan (snd $1) $>)) }+ | FieldId+ { (fst $1, Id (fst $1) NoInfo (snd $1)) }++CFieldPatterns :: { [(Name, PatternBase NoInfo Name)] }+ : CFieldPatterns1 { $1 }+ | { [] }++CFieldPatterns1 :: { [(Name, PatternBase NoInfo Name)] }+ : CFieldPattern ',' CFieldPatterns1 { $1 : $3 }+ | CFieldPattern { [$1] }++CaseLiteral :: { (UncheckedExp, SrcLoc) }+ : PrimLit { (Literal (fst $1) (snd $1), snd $1) }+ | intlit { let L loc (INTLIT x) = $1 in (IntLit x NoInfo loc, loc) }+ | floatlit { let L loc (FLOATLIT x) = $1 in (FloatLit x NoInfo loc, loc) }+ | stringlit { let L loc (STRINGLIT s) = $1 in+ (ArrayLit (map (flip Literal loc . SignedValue . Int32Value . fromIntegral . ord) s) NoInfo loc, loc) }+ | VConstr0 { (VConstr0 (fst $1) NoInfo (snd $1), snd $1) } LoopForm :: { LoopFormBase NoInfo Name } LoopForm : for VarId '<' Exp
src/Language/Futhark/Pretty.hs view
@@ -122,6 +122,8 @@ | otherwise = braces (commasep $ map ppField $ M.toList fs) where ppField (name, t) = text (nameToString name) <> colon <+> ppr t+ ppr (ArrayEnumElem cs _) =+ cat $ punctuate (text " | ") $ map ((text "#" <>) . ppr) cs instance Pretty (ShapeDecl dim) => Pretty (TypeBase dim as) where ppr = pprPrec 0@@ -140,6 +142,8 @@ parens (pprName v <> colon <+> ppr t1) <+> text "->" <+> ppr t2 pprPrec p (Arrow _ Nothing t1 t2) = parensIf (p > 0) $ pprPrec 1 t1 <+> text "->" <+> ppr t2+ pprPrec _ (Enum cs) =+ cat $ punctuate (text " | ") $ map ((text "#" <>) . ppr) cs instance Pretty (ShapeDecl dim) => Pretty (TypeArg dim as) where ppr (TypeArgDim d _) = ppr $ ShapeDecl [d]@@ -156,6 +160,8 @@ ppr (TEArrow (Just v) t1 t2 _) = parens v' <+> text "->" <+> ppr t2 where v' = pprName v <> colon <+> ppr t1 ppr (TEArrow Nothing t1 t2 _) = ppr t1 <+> text "->" <+> ppr t2+ ppr (TEEnum cs _) =+ cat $ punctuate (text " | ") $ map ((text "#" <>) . ppr) cs instance (Eq vn, IsName vn) => Pretty (TypeArgExp vn) where ppr (TypeArgExpDim d _) = ppr $ ShapeDecl [d]@@ -315,11 +321,16 @@ text "loop" <+> spread (map ppr tparams ++ [ppr pat]) <+> equals <+> ppr initexp <+> ppr form <+> text "do" </> indent 2 (ppr loopbody)+ pprPrec _ (VConstr0 n _ _) = text "#" <> ppr n+ pprPrec _ (Match e cs _ _) = text "match" <+> ppr e </> ppr cs instance (Eq vn, IsName vn, Annot f) => Pretty (FieldBase f vn) where ppr (RecordFieldExplicit name e _) = ppr name <> equals <> ppr e ppr (RecordFieldImplicit name _ _) = pprName name +instance (Eq vn, IsName vn, Annot f) => Pretty (CaseBase f vn) where+ ppr (CasePat p e _) = ppr p <+> text "->" <+> ppr e+ instance (Eq vn, IsName vn, Annot f) => Pretty (LoopFormBase f vn) where ppr (For i ubound) = text "for" <+> ppr i <+> text "<" <+> align (ppr ubound)@@ -340,6 +351,7 @@ ppr (Wildcard t _) = case unAnnot t of Just t' -> parens $ text "_" <> colon <+> ppr t' Nothing -> text "_"+ ppr (PatternLit e _ _) = ppr e ppAscription :: (Eq vn, IsName vn, Annot f) => Maybe (TypeDeclBase f vn) -> Doc ppAscription Nothing = mempty@@ -349,12 +361,13 @@ ppr = stack . punctuate line . map ppr . progDecs instance (Eq vn, IsName vn, Annot f) => Pretty (DecBase f vn) where- ppr (ValDec dec) = ppr dec- ppr (TypeDec dec) = ppr dec- ppr (SigDec sig) = ppr sig- ppr (ModDec sd) = ppr sd- ppr (OpenDec x _ _) = text "open" <+> ppr x- ppr (LocalDec dec _) = text "local" <+> ppr dec+ ppr (ValDec dec) = ppr dec+ ppr (TypeDec dec) = ppr dec+ ppr (SigDec sig) = ppr sig+ ppr (ModDec sd) = ppr sd+ ppr (OpenDec x _) = text "open" <+> ppr x+ ppr (LocalDec dec _) = text "local" <+> ppr dec+ ppr (ImportDec x _ _) = text "import" <+> ppr x instance (Eq vn, IsName vn, Annot f) => Pretty (ModExpBase f vn) where ppr (ModVar v _) = ppr v
src/Language/Futhark/Syntax.hs view
@@ -51,6 +51,7 @@ , DimIndexBase(..) , ExpBase(..) , FieldBase(..)+ , CaseBase(..) , LoopFormBase (..) , PatternBase(..) , StreamForm(..)@@ -96,6 +97,7 @@ import qualified Data.Set as S import Data.Traversable import qualified Data.Semigroup as Sem+import Data.List import Prelude import Futhark.Representation.Primitive (FloatType (..),@@ -311,6 +313,7 @@ ArrayPrimElem PrimType as | ArrayPolyElem TypeName [TypeArg dim as] as | ArrayRecordElem (M.Map Name (RecordArrayElemTypeBase dim as))+ | ArrayEnumElem [Name] as deriving (Eq, Show) instance Bitraversable ArrayElemTypeBase where@@ -320,6 +323,8 @@ ArrayPolyElem t <$> traverse (bitraverse f g) args <*> g as bitraverse f g (ArrayRecordElem fs) = ArrayRecordElem <$> traverse (bitraverse f g) fs+ bitraverse _ g (ArrayEnumElem cs as) =+ ArrayEnumElem cs <$> g as instance Bifunctor ArrayElemTypeBase where bimap = bimapDefault@@ -332,6 +337,7 @@ -- '==', aliases are ignored, but dimensions much match. Function -- parameter names are ignored. data TypeBase dim as = Prim PrimType+ | Enum [Name] | Array (ArrayElemTypeBase dim as) (ShapeDecl dim) Uniqueness | Record (M.Map Name (TypeBase dim as)) | TypeVar as Uniqueness TypeName [TypeArg dim as]@@ -346,6 +352,7 @@ Record x1 == Record x2 = x1 == x2 TypeVar _ u1 x1 y1 == TypeVar _ u2 x2 y2 = u1 == u2 && x1 == x2 && y1 == y2 Arrow _ _ x1 y1 == Arrow _ _ x2 y2 = x1 == x2 && y1 == y2+ Enum ns1 == Enum ns2 = sort ns1 == sort ns2 _ == _ = False instance Bitraversable TypeBase where@@ -357,6 +364,7 @@ TypeVar <$> g als <*> pure u <*> pure t <*> traverse (bitraverse f g) args bitraverse f g (Arrow als v t1 t2) = Arrow <$> g als <*> pure v <*> bitraverse f g t1 <*> bitraverse f g t2+ bitraverse _ _ (Enum n) = pure $ Enum n instance Bifunctor TypeBase where bimap = bimapDefault@@ -395,6 +403,7 @@ | TEUnique (TypeExp vn) SrcLoc | TEApply (TypeExp vn) (TypeArgExp vn) SrcLoc | TEArrow (Maybe vn) (TypeExp vn) (TypeExp vn) SrcLoc+ | TEEnum [Name] SrcLoc deriving (Eq, Show) instance Located (TypeExp vn) where@@ -405,6 +414,7 @@ locOf (TEUnique _ loc) = locOf loc locOf (TEApply _ _ loc) = locOf loc locOf (TEArrow _ _ _ loc) = locOf loc+ locOf (TEEnum _ loc) = locOf loc data TypeArgExp vn = TypeArgExpDim (DimDecl vn) SrcLoc | TypeArgExpType (TypeExp vn)@@ -709,6 +719,12 @@ -- and return the value of the second expression if it -- does. + | VConstr0 Name (f CompType) SrcLoc+ -- ^ An enum element, e.g., @#foo@.++ | Match (ExpBase f vn) [CaseBase f vn] (f CompType) SrcLoc+ -- ^ A match expression.+ deriving instance Showable f vn => Show (ExpBase f vn) data StreamForm f vn = MapLike StreamOrd@@ -756,6 +772,8 @@ locOf (Stream _ _ _ pos) = locOf pos locOf (Unsafe _ loc) = locOf loc locOf (Assert _ _ _ loc) = locOf loc+ locOf (VConstr0 _ _ loc) = locOf loc+ locOf (Match _ _ _ loc) = locOf loc -- | An entry in a record literal. data FieldBase f vn = RecordFieldExplicit Name (ExpBase f vn) SrcLoc@@ -767,6 +785,14 @@ locOf (RecordFieldExplicit _ _ loc) = locOf loc locOf (RecordFieldImplicit _ _ loc) = locOf loc +-- | A case in a match expression.+data CaseBase f vn = CasePat (PatternBase f vn) (ExpBase f vn) SrcLoc++deriving instance Showable f vn => Show (CaseBase f vn)++instance Located (CaseBase f vn) where+ locOf (CasePat _ _ loc) = locOf loc+ -- | Whether the loop is a @for@-loop or a @while@-loop. data LoopFormBase f vn = For (IdentBase f vn) (ExpBase f vn) | ForIn (PatternBase f vn) (ExpBase f vn)@@ -781,6 +807,7 @@ | Id vn (f PatternType) SrcLoc | Wildcard (f PatternType) SrcLoc -- Nothing, i.e. underscore. | PatternAscription (PatternBase f vn) (TypeDeclBase f vn) SrcLoc+ | PatternLit (ExpBase f vn) (f PatternType) SrcLoc deriving instance Showable f vn => Show (PatternBase f vn) instance Located (PatternBase f vn) where@@ -790,6 +817,7 @@ locOf (Id _ _ loc) = locOf loc locOf (Wildcard _ loc) = locOf loc locOf (PatternAscription _ _ loc) = locOf loc+ locOf (PatternLit _ _ loc) = locOf loc -- | Documentation strings, including source location. data DocComment = DocComment String SrcLoc@@ -958,17 +986,19 @@ | TypeDec (TypeBindBase f vn) | SigDec (SigBindBase f vn) | ModDec (ModBindBase f vn)- | OpenDec (ModExpBase f vn) (f [VName]) SrcLoc+ | OpenDec (ModExpBase f vn) SrcLoc | LocalDec (DecBase f vn) SrcLoc+ | ImportDec FilePath (f FilePath) SrcLoc deriving instance Showable f vn => Show (DecBase f vn) instance Located (DecBase f vn) where- locOf (ValDec d) = locOf d- locOf (TypeDec d) = locOf d- locOf (SigDec d) = locOf d- locOf (ModDec d) = locOf d- locOf (OpenDec _ _ loc) = locOf loc- locOf (LocalDec _ loc) = locOf loc+ locOf (ValDec d) = locOf d+ locOf (TypeDec d) = locOf d+ locOf (SigDec d) = locOf d+ locOf (ModDec d) = locOf d+ locOf (OpenDec _ loc) = locOf loc+ locOf (LocalDec _ loc) = locOf loc+ locOf (ImportDec _ _ loc) = locOf loc -- | The program described by a single Futhark file. May depend on -- other files.
src/Language/Futhark/Traversals.hs view
@@ -176,6 +176,11 @@ DoLoop <$> mapM (astMap tv) tparams <*> astMap tv mergepat <*> mapOnExp tv mergeexp <*> astMap tv form <*> mapOnExp tv loopbody <*> pure loc+ astMap tv (VConstr0 name t loc) =+ VConstr0 name <$> traverse (mapOnCompType tv) t <*> pure loc+ astMap tv (Match e cases t loc) =+ Match <$> mapOnExp tv e <*> astMap tv cases+ <*> traverse (mapOnCompType tv) t <*> pure loc instance ASTMappable (LoopFormBase Info VName) where astMap tv (For i bound) = For <$> astMap tv i <*> astMap tv bound@@ -194,6 +199,7 @@ TEApply <$> astMap tv t1 <*> astMap tv t2 <*> pure loc astMap tv (TEArrow v t1 t2 loc) = TEArrow v <$> astMap tv t1 <*> astMap tv t2 <*> pure loc+ astMap _ te@TEEnum{} = pure te instance ASTMappable (TypeArgExp VName) where astMap tv (TypeArgExpDim dim loc) =@@ -234,6 +240,7 @@ TypeVar <$> h als <*> pure u <*> f t <*> traverse (traverseTypeArg f g h) args traverseType f g h (Arrow als v t1 t2) = Arrow <$> h als <*> pure v <*> traverseType f g h t1 <*> traverseType f g h t2+traverseType _ _ _ (Enum cs) = pure $ Enum cs traverseArrayElemType :: Applicative f => TypeTraverser f ArrayElemTypeBase dim1 als1 dim2 als2@@ -243,6 +250,8 @@ ArrayPolyElem <$> f t <*> traverse (traverseTypeArg f g h) args <*> h as traverseArrayElemType f g h (ArrayRecordElem fs) = ArrayRecordElem <$> traverse (traverseRecordArrayElemType f g h) fs+traverseArrayElemType _ _ h (ArrayEnumElem cs as) =+ ArrayEnumElem cs <$> h as traverseRecordArrayElemType :: Applicative f => TypeTraverser f RecordArrayElemTypeBase dim1 als1 dim2 als2@@ -294,6 +303,8 @@ PatternAscription <$> astMap tv pat <*> astMap tv t <*> pure loc astMap tv (Wildcard (Info t) loc) = Wildcard <$> (Info <$> mapOnPatternType tv t) <*> pure loc+ astMap tv (PatternLit e (Info t) loc) =+ PatternLit <$> astMap tv e <*> (Info <$> mapOnPatternType tv t) <*> pure loc instance ASTMappable (FieldBase Info VName) where astMap tv (RecordFieldExplicit name e loc) =@@ -301,6 +312,10 @@ astMap tv (RecordFieldImplicit name t loc) = RecordFieldImplicit <$> mapOnName tv name <*> traverse (mapOnCompType tv) t <*> pure loc++instance ASTMappable (CaseBase Info VName) where+ astMap tv (CasePat pat e loc) =+ CasePat <$> astMap tv pat <*> astMap tv e <*> pure loc instance ASTMappable a => ASTMappable (Info a) where astMap tv = traverse $ astMap tv
src/Language/Futhark/TypeChecker.hs view
@@ -52,15 +52,16 @@ -- | Type check a single expression containing no type information, -- yielding either a type error or the same expression annotated with--- type information. See also 'checkProg'.+-- type information. Also returns a list of type parameters, which+-- will be nonempty if the expression is polymorphic. See also+-- 'checkProg'. checkExp :: Imports -> VNameSource -> Env -> UncheckedExp- -> Either TypeError Exp+ -> Either TypeError ([TypeParam], Exp) checkExp files src env e = do- (e', _, _) <- runTypeM env files' (mkInitialImport "") src $- checkOneExp e+ (e', _, _) <- runTypeM env files' (mkInitialImport "") src $ checkOneExp e return e' where files' = M.map fileEnv $ M.fromList files @@ -138,8 +139,8 @@ check Term name loc f OpenDec{} = return- f LocalDec{} = return+ f ImportDec{} = return bindingTypeParams :: [TypeParam] -> TypeM a -> TypeM a bindingTypeParams tparams = localEnv env@@ -447,15 +448,21 @@ when (entry && any isTypeParam tparams') $ throwError $ TypeError loc "Entry point functions may not be polymorphic." - when (entry && singleTuplePattern params') $- warn loc "This entry point accepts a *single* tuple-typed parameter, *not* multiple parameters.\nThis will be an error in the future."- let (rettype_params, rettype') = unfoldFunType rettype when (entry && (any (not . patternOrderZero) params' || any (not . orderZero) rettype_params || not (orderZero rettype'))) $ throwError $ TypeError loc "Entry point functions may not be higher-order." + case (entry, filter nastyParameter params') of+ (True, p : _) -> warn loc $ "Entry point parameter\n\n " <>+ pretty p <> "\n\nwill have an opaque type, so the entry point will likely not be callable."+ _ -> return ()++ when (entry && nastyReturnType maybe_tdecl' rettype) $+ warn loc $ "Entry point return type\n\n " <>+ pretty rettype <> "\n\nwill have an opaque type, so the result will likely not be usable."+ return (mempty { envVtable = M.singleton fname' $ BoundV tparams' $ foldr (uncurry (Arrow ()) . patternParam) rettype params'@@ -464,10 +471,37 @@ }, ValBind entry fname' maybe_tdecl' (Info rettype) tparams' params' body' doc loc) -singleTuplePattern :: [Pattern] -> Bool-singleTuplePattern [TuplePattern _ _] = True-singleTuplePattern _ = False+nastyType :: Monoid als => TypeBase dim als -> Bool+nastyType Prim{} = False+nastyType t@Array{} = nastyType $ stripArray 1 t+nastyType _ = True +nastyReturnType :: Monoid als => Maybe (TypeExp VName) -> TypeBase dim als -> Bool+nastyReturnType _ (Arrow _ _ t1 t2) =+ nastyType t1 || nastyReturnType Nothing t2+nastyReturnType (Just te) _+ | niceTypeExp te = False+nastyReturnType te t+ | Just ts <- isTupleRecord t =+ case te of+ Just (TETuple tes _) -> or $ zipWith nastyType' (map Just tes) ts+ _ -> any nastyType ts+ | otherwise = nastyType' te t+ where nastyType' (Just te') _ | niceTypeExp te' = False+ nastyType' _ t' = nastyType t'++nastyParameter :: Pattern -> Bool+nastyParameter p = nastyType (patternType p) && not (ascripted p)+ where ascripted (PatternAscription _ (TypeDecl te _) _) = niceTypeExp te+ ascripted (PatternParens p' _) = ascripted p'+ ascripted _ = False++niceTypeExp :: TypeExp VName -> Bool+niceTypeExp (TEVar (QualName [] _) _) = True+niceTypeExp (TEApply te TypeArgExpDim{} _) = niceTypeExp te+niceTypeExp (TEArray te _ _) = niceTypeExp te+niceTypeExp _ = False+ checkOneDec :: DecBase NoInfo Name -> TypeM (TySet, Env, DecBase Info VName) checkOneDec (ModDec struct) = do (abs, modenv, struct') <- checkModBind struct@@ -481,17 +515,20 @@ (tenv, tdec') <- checkTypeBind tdec return (mempty, tenv, TypeDec tdec') -checkOneDec (OpenDec x NoInfo loc) = do+checkOneDec (OpenDec x loc) = do (x_abs, x_env, x') <- checkModExpToEnv x- let names = S.toList $ allNamesInEnv x_env- return (x_abs,- x_env,- OpenDec x' (Info names) loc)+ return (x_abs, x_env, OpenDec x' loc) checkOneDec (LocalDec d loc) = do (abstypes, env, d') <- checkOneDec d return (abstypes, env, LocalDec d' loc) +checkOneDec (ImportDec name NoInfo loc) = do+ (name', env) <- lookupImport loc name+ when ("/futlib" `isPrefixOf` name) $+ warn loc $ name ++ " is already implicitly imported."+ return (mempty, env, ImportDec name (Info name') loc)+ checkOneDec (ValDec vb) = do (env, vb') <- checkValBind vb return (mempty, env, ValDec vb')@@ -828,6 +865,8 @@ Prim t substituteInType (Record ts) = Record $ fmap substituteInType ts+ substituteInType (Enum cs) =+ Enum cs substituteInType (Array (ArrayPrimElem t ()) shape u) = Array (ArrayPrimElem t ()) (substituteInShape shape) u substituteInType (Array (ArrayPolyElem (TypeName qs v) targs ()) shape u) =@@ -840,6 +879,8 @@ in case arrayOf (Record ts') (substituteInShape shape) u of Just t' -> t' _ -> error "substituteInType: Cannot create array after substitution."+ substituteInType (Array (ArrayEnumElem cs ()) shape u) =+ Array (ArrayEnumElem cs ()) (substituteInShape shape) u substituteInType (Arrow als v t1 t2) = Arrow als v (substituteInType t1) (substituteInType t2)
src/Language/Futhark/TypeChecker/Terms.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances, DeriveFunctor #-} -- | Facilities for type-checking Futhark terms. Checking a term -- requires a little more context to track uniqueness and such. --@@ -17,6 +18,7 @@ import Control.Monad.State import Control.Monad.RWS import qualified Control.Monad.Fail as Fail+import Data.Char (isAlpha) import Data.List import Data.Loc import Data.Maybe@@ -33,7 +35,7 @@ import Language.Futhark.TypeChecker.Unify import qualified Language.Futhark.TypeChecker.Types as Types import qualified Language.Futhark.TypeChecker.Monad as TypeM-import Futhark.Util.Pretty (Pretty)+import Futhark.Util.Pretty hiding (space, bool) --- Uniqueness @@ -203,7 +205,7 @@ newTypeVar loc desc = do i <- incCounter- v <- newID $ nameFromString $ desc ++ show i+ v <- newID $ mkTypeVarName desc i modifyConstraints $ M.insert v $ NoConstraint Nothing loc return $ TypeVar mempty Nonunique (typeName v) [] @@ -368,7 +370,7 @@ tnames = map typeParamName tparams' (fresh_tnames, inst_list) <- unzip <$> mapM (instantiateTypeParam loc) tparams' let substs = M.fromList $ zip tnames $- map vacuousShapeAnnotations inst_list+ map (Subst . vacuousShapeAnnotations) inst_list t' = substTypesAny (`M.lookup` substs) t return (fresh_tnames, t') @@ -377,7 +379,7 @@ instantiateTypeParam :: Monoid as => SrcLoc -> TypeParam -> TermTypeM (VName, TypeBase dim as) instantiateTypeParam loc tparam = do i <- incCounter- v <- newID $ nameFromString $ baseString (typeParamName tparam) ++ show i+ v <- newID $ mkTypeVarName (takeWhile isAlpha (baseString (typeParamName tparam))) i modifyConstraints $ M.insert v $ NoConstraint (Just l) loc return (v, TypeVar mempty Nonunique (typeName v) []) where l = case tparam of TypeParamType x _ _ -> x@@ -396,8 +398,7 @@ useAfterConsume :: MonadTypeChecker m => Name -> SrcLoc -> SrcLoc -> m a useAfterConsume name rloc wloc = throwError $ TypeError rloc $- "Variable " ++ pretty name ++ " used," ++- "but previously consumed at " ++ locStr wloc ++ ". (Possibly through aliasing)"+ "Variable " ++ pretty name ++ " previously consumed at " ++ locStr wloc ++ ". (Possibly through aliasing)" consumeAfterConsume :: MonadTypeChecker m => Name -> SrcLoc -> SrcLoc -> m a consumeAfterConsume name loc1 loc2 =@@ -544,6 +545,17 @@ pure (TypeDecl t' (Info st)) <*> pure loc where unifyUniqueness u1 u2 = if u2 `subuniqueOf` u1 then Just u1 else Nothing +checkPattern' (PatternLit e NoInfo loc) (Ascribed t) = do+ e' <- checkExp e+ t' <- expType e'+ unify loc (toStructural t') (toStructural t)+ return $ PatternLit e' (Info (vacuousShapeAnnotations t')) loc++checkPattern' (PatternLit e NoInfo loc) NoneInferred = do+ e' <- checkExp e+ t' <- expType e'+ return $ PatternLit e' (Info (vacuousShapeAnnotations t')) loc+ bindPatternNames :: PatternBase NoInfo Name -> TermTypeM a -> TermTypeM a bindPatternNames = bindSpaced . map asTerm . S.toList . patIdentSet where asTerm v = (Term, identName v)@@ -695,6 +707,7 @@ patternUses :: Pattern -> ([VName], [VName]) patternUses Id{} = mempty patternUses Wildcard{} = mempty+patternUses PatternLit{} = mempty patternUses (PatternParens p _) = patternUses p patternUses (TuplePattern ps _) = foldMap patternUses ps patternUses (RecordPattern fs _) = foldMap (patternUses . snd) fs@@ -709,6 +722,7 @@ typeExpUses (TEArrow _ t1 t2 _) = let (pos, neg) = typeExpUses t1 <> typeExpUses t2 in (mempty, pos <> neg)+ typeExpUses TEEnum{} = mempty typeArgUses (TypeArgExpDim d _) = dimDeclUses d typeArgUses (TypeArgExpType te) = typeExpUses te @@ -1226,6 +1240,7 @@ RecordPattern (map (fmap uniquePat) fs) ploc uniquePat (PatternAscription p t ploc) = PatternAscription p t ploc+ uniquePat p@PatternLit{} = p -- Make the pattern unique where needed. pat' = uniquePat pat@@ -1271,6 +1286,176 @@ then return pat' else convergePattern pat' body_cons' body_t' body_loc +checkExp (VConstr0 name NoInfo loc) = do+ t <- newTypeVar loc "t"+ mustHaveConstr loc name t+ return $ VConstr0 name (Info t) loc++checkExp (Match _ [] NoInfo loc) =+ typeError loc "Match expressions must have at least one case."++checkExp (Match e (c:cs) NoInfo loc) =+ sequentially (checkExp e) $ \e' _ -> do+ mt <- expType e'+ (cs', t) <- checkCases mt c cs+ zeroOrderType loc "returned from pattern match" t+ return $ Match e' cs' (Info t) loc++checkCases :: CompType+ -> CaseBase NoInfo Name+ -> [CaseBase NoInfo Name]+ -> TermTypeM ([CaseBase Info VName], CompType)+checkCases mt c [] = do+ (c', t) <- checkCase mt c+ return ([c'], t)+checkCases mt c (c2:cs) = do+ (((c', c_t), (cs', cs_t)), dflow) <-+ tapOccurences $ checkCase mt c `alternative` checkCases mt c2 cs+ unify (srclocOf c) (toStruct c_t) (toStruct cs_t)+ let t = unifyTypeAliases c_t cs_t `addAliases` (`S.difference` allConsumed dflow)+ return (c':cs', t)++checkCase :: CompType -> CaseBase NoInfo Name+ -> TermTypeM (CaseBase Info VName, CompType)+checkCase mt (CasePat p caseExp loc) =+ bindingPattern [] p (Ascribed $ vacuousShapeAnnotations mt) $ \_ p' -> do+ caseExp' <- checkExp caseExp+ caseType <- expType caseExp'+ return (CasePat p' caseExp' loc, caseType)++-- | An unmatched pattern. Used in in the generation of+-- unmatched pattern warnings by the type checker.+data Unmatched p = UnmatchedNum p [ExpBase Info VName]+ | UnmatchedBool p+ | UnmatchedEnum p+ | Unmatched p+ deriving (Functor, Show)++instance Pretty (Unmatched (PatternBase Info VName)) where+ ppr um = case um of+ (UnmatchedNum p nums) -> ppr' p <+> text "where p is not one of" <+> ppr nums+ (UnmatchedBool p) -> ppr' p+ (UnmatchedEnum p) -> ppr' p+ (Unmatched p) -> ppr' p+ where+ ppr' (PatternAscription p t _) = ppr p <> text ":" <+> ppr t+ ppr' (PatternParens p _) = parens $ ppr' p+ ppr' (Id v _ _) = pprName v+ ppr' (TuplePattern pats _) = parens $ commasep $ map ppr' pats+ ppr' (RecordPattern fs _) = braces $ commasep $ map ppField fs+ where ppField (name, t) = text (nameToString name) <> equals <> ppr' t+ ppr' Wildcard{} = text "_"+ ppr' (PatternLit e _ _) = ppr e++unpackPat :: Pattern -> [Maybe Pattern]+unpackPat Wildcard{} = [Nothing]+unpackPat (PatternParens p _) = unpackPat p+unpackPat Id{} = [Nothing]+unpackPat (TuplePattern ps _) = Just <$> ps+unpackPat (RecordPattern fs _) = Just . snd <$> sortFields (M.fromList fs)+unpackPat (PatternAscription p _ _) = unpackPat p+unpackPat p@PatternLit{} = [Just p]++wildPattern :: Pattern -> Int -> Unmatched Pattern -> Unmatched Pattern+wildPattern (TuplePattern ps loc) pos um = f <$> um+ where f p = TuplePattern (take (pos - 1) ps' ++ [p] ++ drop pos ps') loc+ ps' = map wildOut ps+ wildOut p = Wildcard (Info (patternPatternType p)) (srclocOf p)+wildPattern (RecordPattern fs loc) pos um = wildRecord <$> um+ where wildRecord p =+ RecordPattern (take (pos - 1) fs' ++ [(fst (fs!!(pos - 1)), p)] ++ drop pos fs') loc+ fs' = map wildOut fs+ wildOut (f,p) = (f, Wildcard (Info (patternPatternType p)) (srclocOf p))+wildPattern (PatternAscription p _ _) pos um = wildPattern p pos um+wildPattern (PatternParens p _) pos um = wildPattern p pos um+wildPattern _ _ um = um++checkUnmatched :: (MonadBreadCrumbs m, MonadTypeChecker m) => Exp -> m ()+checkUnmatched e = void $ checkUnmatched' e >> astMap tv e+ where checkUnmatched' (Match _ cs _ loc) =+ let ps = map (\(CasePat p _ _) -> p) cs+ in case unmatched id ps of+ [] -> return ()+ ps' -> typeError loc $ "Unmatched cases in match expression: \n"+ ++ unlines (map ((" " ++) . pretty) ps')+ checkUnmatched' _ = return ()+ tv = ASTMapper { mapOnExp =+ \e' -> checkUnmatched' e' >> return e'+ , mapOnName = pure+ , mapOnQualName = pure+ , mapOnType = pure+ , mapOnCompType = pure+ , mapOnStructType = pure+ , mapOnPatternType = pure+ }++unmatched :: (Unmatched Pattern -> Unmatched Pattern) -> [Pattern] -> [Unmatched Pattern]+unmatched hole (p:ps)+ | sameStructure labeledCols = do+ (i, cols) <- labeledCols+ let hole' p' = hole $ wildPattern p i p'+ case sequence cols of+ Nothing -> []+ Just cs+ | all isPatternLit cs -> map hole' $ localUnmatched cs+ | otherwise -> unmatched hole' cs++ where labeledCols = zip [1..] $ transpose $ map unpackPat (p:ps)++ localUnmatched :: [Pattern] -> [Unmatched Pattern]+ localUnmatched [] = []+ localUnmatched ps'@(p':_) =+ case vacuousShapeAnnotations $ patternType p' of+ Enum cs'' ->+ let matched = nub $ mapMaybe (pExp >=> constr) ps'+ in map (UnmatchedEnum . buildEnum (Enum cs'')) $ cs'' \\ matched+ Prim t+ | not (any idOrWild ps') ->+ case t of+ Bool ->+ let matched = nub $ mapMaybe (pExp >=> bool) $ filter isPatternLit ps'+ in map (UnmatchedBool . buildBool (Prim t)) $ [True, False] \\ matched+ _ ->+ let matched = mapMaybe pExp $ filter isPatternLit ps'+ in [UnmatchedNum (buildId (Info (Prim t)) "p") matched]+ _ -> []++ sameStructure [] = True+ sameStructure (x:xs) = all (\y -> length y == length x' ) xs'+ where (x':xs') = map snd (x:xs)++ pExp (PatternLit e' _ _) = Just e'+ pExp _ = Nothing++ constr (VConstr0 c _ _) = Just c+ constr (Ascript e' _ _) = constr e'+ constr _ = Nothing++ isPatternLit PatternLit{} = True+ isPatternLit (PatternAscription p' _ _) = isPatternLit p'+ isPatternLit (PatternParens p' _) = isPatternLit p'+ isPatternLit _ = False++ idOrWild Id{} = True+ idOrWild Wildcard{} = True+ idOrWild (PatternAscription p' _ _) = idOrWild p'+ idOrWild (PatternParens p' _) = idOrWild p'+ idOrWild _ = False++ bool (Literal (BoolValue b) _ ) = Just b+ bool _ = Nothing++ buildEnum t c =+ PatternLit (VConstr0 c (Info t) noLoc) (Info (vacuousShapeAnnotations t)) noLoc+ buildBool t b =+ PatternLit (Literal (BoolValue b) noLoc) (Info (vacuousShapeAnnotations t)) noLoc+ 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++unmatched _ _ = []+ checkIdent :: IdentBase NoInfo Name -> TermTypeM Ident checkIdent (Ident name _ loc) = do (QualName _ name', vt) <- lookupVar loc (qualName name)@@ -1364,11 +1549,14 @@ consumeArg loc at Consume = return [consumption (aliases at) loc] consumeArg loc at _ = return [observation (aliases at) loc] -checkOneExp :: UncheckedExp -> TypeM Exp+checkOneExp :: UncheckedExp -> TypeM ([TypeParam], Exp) checkOneExp e = fmap fst . runTermTypeM $ do e' <- checkExp e+ let t = vacuousShapeAnnotations $ toStruct $ typeOf e'+ tparams <- letGeneralise [] [t] mempty fixOverloadedTypes- updateExpTypes e'+ e'' <- updateExpTypes e'+ return (tparams, e'') -- | Type-check a top-level (or module-level) function definition. checkFunDef :: (Name, Maybe UncheckedTypeExp,@@ -1388,6 +1576,10 @@ maybe_retdecl' <- traverse updateExpTypes maybe_retdecl rettype' <- normaliseType rettype + -- Check if pattern matches are exhaustive and yield+ -- errors if not.+ checkUnmatched body'+ return (fname, tparams, params', maybe_retdecl', rettype', body') -- | This is "fixing" as in "setting them", not "correcting them". We@@ -1420,6 +1612,11 @@ where fs' = intercalate ", " $ map field $ M.toList fs field (l, t) = pretty l ++ ": " ++ pretty t + fixOverloaded (_, HasConstrs cs loc) =+ typeError loc $ unlines [ "Type is ambiguous (must be an enum with constructors: " ++ cs' ++ ")."+ ,"Add a type annotation to disambiguate the type."]+ where cs' = intercalate " | " $ map (\c -> '#' : pretty c) cs+ fixOverloaded _ = return () checkFunDef' :: (Name, Maybe UncheckedTypeExp,@@ -1449,32 +1646,7 @@ return (Just retdecl', retdecl_type) Nothing -> return (Nothing, vacuousShapeAnnotations $ toStruct body_t) - -- Candidates for let-generalisation are those type variables that- ---- -- (1) were not known before we checked this function, and- --- -- (2) are not used in the (new) definition of any type variables- -- known before we checked this function.- --- -- (3) are not referenced from an overloaded type (for example,- -- are the element types of an incompletely resolved record type).- -- This is a bit more restrictive than I'd like, and SML for- -- example does not have this restriction.- now_substs <- getConstraints- let then_type_variables = S.fromList $ M.keys then_substs- then_type_constraints = constraintTypeVars $- M.filterWithKey (\k _ -> k `S.member` then_type_variables) now_substs- keep_type_variables = then_type_variables <>- then_type_constraints <>- overloadedTypeVars now_substs-- let new_substs = M.filterWithKey (\k _ -> not (k `S.member` keep_type_variables)) now_substs- tparams'' <- closeOverTypes new_substs tparams' $- rettype : map patternStructType params''-- -- We keep those type variables that were not closed over by- -- let-generalisation.- modifyConstraints $ M.filterWithKey $ \k _ -> k `notElem` map typeParamName tparams''+ tparams'' <- letGeneralise tparams' (rettype : map patternStructType params'') then_substs bindSpaced [(Term, fname)] $ do fname' <- checkName Term fname loc@@ -1510,6 +1682,39 @@ returnAliasing (Record ets1) (Record ets2) = concat $ M.elems $ M.intersectionWith returnAliasing ets1 ets2 returnAliasing expected got = [(uniqueness expected, aliases got)]++letGeneralise :: [TypeParam]+ -> [StructType]+ -> Constraints+ -> TermTypeM [TypeParam]+letGeneralise tparams ts then_substs = do+ now_substs <- getConstraints+ -- Candidates for let-generalisation are those type variables that+ --+ -- (1) were not known before we checked this function, and+ --+ -- (2) are not used in the (new) definition of any type variables+ -- known before we checked this function.+ --+ -- (3) are not referenced from an overloaded type (for example,+ -- are the element types of an incompletely resolved record type).+ -- This is a bit more restrictive than I'd like, and SML for+ -- example does not have this restriction.+ let then_type_variables = S.fromList $ M.keys then_substs+ then_type_constraints = constraintTypeVars $+ M.filterWithKey (\k _ -> k `S.member` then_type_variables) now_substs+ keep_type_variables = then_type_variables <>+ then_type_constraints <>+ overloadedTypeVars now_substs++ let new_substs = M.filterWithKey (\k _ -> not (k `S.member` keep_type_variables)) now_substs+ tparams' <- closeOverTypes new_substs tparams ts++ -- We keep those type variables that were not closed over by+ -- let-generalisation.+ modifyConstraints $ M.filterWithKey $ \k _ -> k `notElem` map typeParamName tparams'++ return tparams' checkFunBody :: ExpBase NoInfo Name -> Maybe StructType
src/Language/Futhark/TypeChecker/Types.hs view
@@ -15,6 +15,7 @@ , substituteTypes , substituteTypesInBoundV + , Subst(..) , Substitutable(..) , substTypesAny )@@ -58,6 +59,8 @@ (M.intersectionWith (,) ts1 ts2) unifyTypesU uf (Arrow as1 mn1 t1 t1') (Arrow as2 _ t2 t2') = Arrow (as1 <> as2) mn1 <$> unifyTypesU (flip uf) t1 t2 <*> unifyTypesU uf t1' t2'+unifyTypesU _ e1@Enum{} e2@Enum{}+ | e1 == e2 = Just e1 unifyTypesU _ _ _ = Nothing unifyTypeArgs :: (Monoid als, Eq als, ArrayDim dim) =>@@ -85,6 +88,9 @@ | sort (M.keys et1) == sort (M.keys et2) = ArrayRecordElem <$> traverse (uncurry $ unifyRecordArrayElemTypes uf) (M.intersectionWith (,) et1 et2)+unifyArrayElemTypes _ (ArrayEnumElem cs1 als1) (ArrayEnumElem cs2 als2)+ | cs1 == cs2 =+ Just $ ArrayEnumElem cs1 (als1 <> als2) unifyArrayElemTypes _ _ _ = Nothing @@ -170,6 +176,7 @@ mayContainArray (Record fs) = any mayContainArray fs mayContainArray TypeVar{} = True mayContainArray Arrow{} = False+ mayContainArray Enum{} = False checkTypeExp (TEArrow (Just v) t1 t2 loc) = do (t1', st1, _) <- checkTypeExp t1 bindSpaced [(Term, v)] $ do@@ -227,6 +234,12 @@ throwError $ TypeError tloc $ "Type argument " ++ pretty a ++ " not valid for a type parameter " ++ pretty p +checkTypeExp t@(TEEnum names loc) = do+ unless (sort names == sort (nub names)) $+ throwError $ TypeError loc $ "Duplicate constructors in " ++ pretty t+ unless (length names <= 256) $+ throwError $ TypeError loc "Enums must have 256 or fewer constructors."+ return (TEEnum names loc, Enum names, Unlifted) checkNamedDim :: MonadTypeChecker m => SrcLoc -> QualName Name -> m (QualName VName)@@ -249,6 +262,7 @@ check (TuplePattern ps _) = mapM_ check ps check (RecordPattern fs _) = mapM_ (check . snd) fs check (PatternAscription p _ _) = check p+ check PatternLit{} = return () seen v loc = do already <- gets $ M.lookup v@@ -276,6 +290,7 @@ pats (TEApply t1 (TypeArgExpType t2) _) = pats t1 ++ pats t2 pats (TEApply t1 TypeArgExpDim{} _) = pats t1 pats TEVar{} = []+ pats TEEnum{} = [] checkTypeParams :: MonadTypeChecker m => [TypeParamBase Name]@@ -323,6 +338,7 @@ Record $ fmap (substituteTypes substs) ts Arrow als v t1 t2 -> Arrow als v (substituteTypes substs t1) (substituteTypes substs t2)+ Enum cs -> Enum cs where nope = error "substituteTypes: Cannot create array after substitution." substituteTypesInArrayElem (ArrayPrimElem t ()) =@@ -337,6 +353,8 @@ Record ts' where ts' = fmap (substituteTypes substs . fst . recordArrayElemToType) ts+ substituteTypesInArrayElem (ArrayEnumElem cs ()) =+ Enum cs substituteInTypeArg (TypeArgDim d loc) = TypeArgDim (substituteInDim d) loc@@ -370,27 +388,37 @@ mkSubst p a = error $ "applyType mkSubst: cannot substitute " ++ pretty a ++ " for " ++ pretty p +-- | A type substituion may be a substitution or a yet-unknown+-- substitution (but which is certainly an overloaded primitive+-- type!). The latter is used to remove aliases from types that are+-- yet-unknown but that we know cannot carry aliases (see issue #682).+data Subst t = Subst t | PrimSubst++instance Functor Subst where+ fmap f (Subst t) = Subst $ f t+ fmap _ PrimSubst = PrimSubst+ -- | Class of types which allow for substitution of types with no -- annotations for type variable names. class Substitutable a where- applySubst :: (VName -> Maybe (TypeBase () ())) -> a -> a+ applySubst :: (VName -> Maybe (Subst (TypeBase () ()))) -> a -> a instance Substitutable (TypeBase () ()) where applySubst = substTypesAny instance Substitutable (TypeBase () Names) where- applySubst = substTypesAny . (fmap fromStruct.)+ applySubst = substTypesAny . (fmap (fmap fromStruct).) instance Substitutable (TypeBase (DimDecl VName) ()) where- applySubst = substTypesAny . (fmap vacuousShapeAnnotations.)+ applySubst = substTypesAny . (fmap (fmap vacuousShapeAnnotations).) instance Substitutable (TypeBase (DimDecl VName) Names) where- applySubst = substTypesAny . (fmap (vacuousShapeAnnotations . fromStruct).)+ applySubst = substTypesAny . (fmap (fmap (vacuousShapeAnnotations . fromStruct)).) -- | Perform substitutions, from type names to types, on a type. Works -- regardless of what shape and uniqueness information is attached to the type. substTypesAny :: (ArrayDim dim, Monoid as) =>- (VName -> Maybe (TypeBase dim as))+ (VName -> Maybe (Subst (TypeBase dim as))) -> TypeBase dim as -> TypeBase dim as substTypesAny lookupSubst ot = case ot of Prim t -> Prim t@@ -398,24 +426,30 @@ uncurry arrayOfWithAliases (subsArrayElem et) shape u -- We only substitute for a type variable with no arguments, since -- type parameters cannot have higher kind.- TypeVar _ u v []- | Just t <- lookupSubst $ qualLeaf (qualNameFromTypeName v) ->- t `setUniqueness` u- TypeVar als u v targs -> TypeVar als u v $ map subsTypeArg targs+ TypeVar als u v targs ->+ case lookupSubst $ qualLeaf (qualNameFromTypeName v) of+ Just (Subst t) -> t `setUniqueness` u+ Just PrimSubst -> TypeVar mempty u v $ map subsTypeArg targs+ Nothing -> TypeVar als u v $ map subsTypeArg targs Record ts -> Record $ fmap (substTypesAny lookupSubst) ts Arrow als v t1 t2 -> Arrow als v (substTypesAny lookupSubst t1) (substTypesAny lookupSubst t2)+ Enum names -> Enum names where nope = error "substTypesAny: Cannot create array after substitution." subsArrayElem (ArrayPrimElem t as) = (Prim t, as)- subsArrayElem (ArrayPolyElem v [] as)- | Just t <- lookupSubst $ qualLeaf (qualNameFromTypeName v) = (t, as) subsArrayElem (ArrayPolyElem v targs as) =- (TypeVar as Nonunique v (map subsTypeArg targs), as)+ case lookupSubst $ qualLeaf $ qualNameFromTypeName v of+ Just (Subst t) -> (t, as)+ -- It is intentional that we do not handle PrimSubst+ -- specially here, as we are inside an array, and that+ -- gives the aliasing.+ _ -> (TypeVar as Nonunique v (map subsTypeArg targs), as) subsArrayElem (ArrayRecordElem ts) = let ts' = fmap recordArrayElemToType ts in (Record $ fmap (substTypesAny lookupSubst . fst) ts', foldMap snd ts')+ subsArrayElem (ArrayEnumElem cs as) = (Enum cs, as) subsTypeArg (TypeArgType t loc) = TypeArgType (substTypesAny lookupSubst t) loc
src/Language/Futhark/TypeChecker/Unify.hs view
@@ -7,8 +7,10 @@ , MonadUnify(..) , BreadCrumb(..) , typeError+ , mkTypeVarName , zeroOrderType+ , mustHaveConstr , mustHaveField , mustBeOneOf , equalityType@@ -46,6 +48,7 @@ | Overloaded [PrimType] SrcLoc | HasFields (M.Map Name (TypeBase () ())) SrcLoc | Equality SrcLoc+ | HasConstrs [Name] SrcLoc deriving Show instance Located Constraint where@@ -55,10 +58,13 @@ locOf (Overloaded _ loc) = locOf loc locOf (HasFields _ loc) = locOf loc locOf (Equality loc) = locOf loc+ locOf (HasConstrs _ loc) = locOf loc -lookupSubst :: VName -> Constraints -> Maybe (TypeBase () ())-lookupSubst v constraints = do Constraint t _ <- M.lookup v constraints- Just t+lookupSubst :: VName -> Constraints -> Maybe (Subst (TypeBase () ()))+lookupSubst v constraints = case M.lookup v constraints of+ Just (Constraint t _) -> Just $ Subst t+ Just Overloaded{} -> Just PrimSubst+ _ -> Nothing class (MonadBreadCrumbs m, MonadError TypeError m) => MonadUnify m where getConstraints :: m Constraints@@ -149,13 +155,14 @@ applySubstInConstraint :: VName -> TypeBase () () -> Constraint -> Constraint applySubstInConstraint vn tp (Constraint t loc) =- Constraint (applySubst (`M.lookup` M.singleton vn tp) t) loc+ Constraint (applySubst (flip M.lookup $ M.singleton vn $ Subst tp) t) loc applySubstInConstraint vn tp (HasFields fs loc) =- HasFields (M.map (applySubst (`M.lookup` M.singleton vn tp)) fs) loc+ HasFields (M.map (applySubst (flip M.lookup $ M.singleton vn $ Subst tp)) fs) loc applySubstInConstraint _ _ (NoConstraint l loc) = NoConstraint l loc applySubstInConstraint _ _ (Overloaded ts loc) = Overloaded ts loc applySubstInConstraint _ _ (Equality loc) = Equality loc applySubstInConstraint _ _ (ParamType l loc) = ParamType l loc+applySubstInConstraint _ _ (HasConstrs ns loc) = HasConstrs ns loc linkVarToType :: MonadUnify m => SrcLoc -> VName -> TypeBase () () -> m () linkVarToType loc vn tp = do@@ -177,7 +184,8 @@ | not $ isRigid v constraints -> linkVarToTypes loc v ts _ -> typeError loc $ "Cannot unify `" ++ prettyName vn ++ "' with type `" ++- pretty tp ++ "' (must be one of " ++ intercalate ", " (map pretty ts) +++ pretty tp ++ "' (`" ++ prettyName vn +++ "` must be one of " ++ intercalate ", " (map pretty ts) ++ " due to use at " ++ locStr old_loc ++ ")." Just (HasFields required_fields old_loc) -> case tp of@@ -198,6 +206,21 @@ pretty tp ++ "' (must be a record with fields {" ++ required_fields' ++ "} due to use at " ++ locStr old_loc ++ ")."+ Just (HasConstrs cs old_loc) ->+ case tp of+ Enum t_cs+ | intersect cs t_cs == cs -> return ()+ | otherwise -> typeError loc $+ "Cannot unify `" ++ prettyName vn ++ "' with type `"+ ++ pretty tp ++ "'"+ TypeVar _ _ (TypeName [] v) []+ | not $ isRigid v constraints ->+ let addConstrs (HasConstrs cs' loc') (HasConstrs cs'' _) =+ HasConstrs (cs' `union` cs'') loc'+ addConstrs c _ = c+ in modifyConstraints $ M.insertWith addConstrs v $+ HasConstrs cs old_loc+ _ -> typeError loc "Cannot unify." _ -> return () where tp' = removeUniqueness tp @@ -260,6 +283,8 @@ modifyConstraints $ M.insert vn (Equality loc) Just (Overloaded _ _) -> return () -- All primtypes support equality.+ Just HasConstrs{} ->+ return () _ -> typeError loc $ "Type " ++ pretty (prettyName vn) ++ " does not support equality."@@ -287,6 +312,26 @@ locStr ploc ++ " may be a function." _ -> return () +mustHaveConstr :: MonadUnify m =>+ SrcLoc -> Name -> TypeBase dim as -> m ()+mustHaveConstr loc c t = do+ constraints <- getConstraints+ case t of+ TypeVar _ _ (TypeName _ tn) []+ | Just NoConstraint{} <- M.lookup tn constraints ->+ modifyConstraints $ M.insert tn $ HasConstrs [c] loc+ | Just (HasConstrs cs _) <- M.lookup tn constraints ->+ if c `elem` cs+ then return ()+ else modifyConstraints $ M.insert tn $ HasConstrs (c:cs) loc+ Enum cs+ | c `elem` cs -> return ()+ | otherwise -> throwError $ TypeError loc $+ "Type " ++ pretty (toStructural t) +++ " does not have a " ++ pretty c ++ " constructor."+ _ -> do unify loc (toStructural t) $ Enum [c]+ return ()+ mustHaveField :: (MonadUnify m, Monoid as) => SrcLoc -> Name -> TypeBase dim as -> m (TypeBase dim as) mustHaveField loc l t = do@@ -300,7 +345,7 @@ return l_type | Just (HasFields fields _) <- M.lookup tn constraints -> do case M.lookup l fields of- Just t' -> unify loc (toStructural t) t'+ Just t' -> unify loc l_type' t' Nothing -> modifyConstraints $ M.insert tn $ HasFields (M.insert l l_type' fields) loc return l_type@@ -332,9 +377,18 @@ i <- do (x, i) <- get put (x, i+1) return i- let v = VName (nameFromString $ desc ++ show i) 0+ let v = VName (mkTypeVarName desc i) 0 modifyConstraints $ M.insert v $ NoConstraint Nothing loc return $ TypeVar mempty Nonunique (typeName v) []++-- | Construct a the name of a new type variable given a base+-- description and a tag number (note that this is distinct from+-- actually constructing a VName; the tag here is intended for human+-- consumption but the machine does not care).+mkTypeVarName :: String -> Int -> Name+mkTypeVarName desc i =+ nameFromString $ desc ++ mapMaybe subscript (show i)+ where subscript = flip lookup $ zip "0123456789" "₀₁₂₃₄₅₆₇₈₉" instance MonadBreadCrumbs UnifyM where
src/futhark-bench.hs view
@@ -10,11 +10,11 @@ import Control.Monad.Except import qualified Data.ByteString.Char8 as SBS import qualified Data.ByteString.Lazy.Char8 as LBS+import qualified Data.Map as M import Data.Either import Data.Maybe import Data.Semigroup ((<>)) import Data.List-import qualified Data.Map as M import qualified Data.Text as T import qualified Data.Text.IO as T import qualified Data.Text.Encoding as T@@ -27,6 +27,7 @@ import System.Process.ByteString (readProcessWithExitCode) import System.Exit import qualified Data.Aeson as JSON+import qualified Data.Aeson.Encoding.Internal as JSON import Text.Printf import Text.Regex.TDFA @@ -57,24 +58,29 @@ data DataResult = DataResult String (Either T.Text ([RunResult], T.Text)) data BenchResult = BenchResult FilePath [DataResult] -resultsToJSON :: [BenchResult] -> JSON.Value-resultsToJSON = JSON.toJSON . M.fromList . map benchResultToJSObject- where benchResultToJSObject- :: BenchResult- -> (String, JSON.Value)- benchResultToJSObject (BenchResult prog rs) =- (prog, JSON.toJSON $ M.fromList- [("datasets" :: String, M.fromList $ map dataResultToJSObject rs)])- dataResultToJSObject- :: DataResult- -> (String, JSON.Value)- dataResultToJSObject (DataResult desc (Left err)) =- (desc, JSON.toJSON $ show err)- dataResultToJSObject (DataResult desc (Right (runtimes, progerr))) =- (desc, JSON.toJSON $ M.fromList- [("runtimes" :: String, JSON.toJSON $ map runMicroseconds runtimes),- ("stderr", JSON.toJSON $ show progerr)])+-- Intermediate types to help write the JSON instances.+newtype DataResults = DataResults [DataResult] +instance JSON.ToJSON DataResults where+ toJSON (DataResults rs) =+ JSON.object $ map dataResultJSON rs+ toEncoding (DataResults rs) =+ JSON.pairs $ mconcat $ map (uncurry (JSON..=) . dataResultJSON) rs++dataResultJSON :: DataResult -> (T.Text, JSON.Value)+dataResultJSON (DataResult desc (Left err)) =+ (T.pack desc, JSON.toJSON $ show err)+dataResultJSON (DataResult desc (Right (runtimes, progerr))) =+ (T.pack desc, JSON.object+ [("runtimes", JSON.toJSON $ map runMicroseconds runtimes),+ ("stderr", JSON.toJSON progerr)])++encodeBenchResults :: [BenchResult] -> LBS.ByteString+encodeBenchResults rs =+ JSON.encodingToLazyByteString $ JSON.pairs $ mconcat $ do+ BenchResult prog r <- rs+ return $ T.pack prog JSON..= M.singleton ("datasets" :: T.Text) (DataResults r)+ fork :: (a -> IO b) -> a -> IO (MVar b) fork f x = do cell <- newEmptyMVar void $ forkIO $ do result <- f x@@ -107,7 +113,7 @@ results <- concat <$> mapM (runBenchmark opts) compiled_benchmarks case optJSON opts of Nothing -> return ()- Just file -> LBS.writeFile file $ JSON.encode $ resultsToJSON results+ Just file -> LBS.writeFile file $ encodeBenchResults results when (anyFailed results) exitFailure where ignored f = any (`match` f) $ optIgnoreFiles opts
src/futhark-dataset.hs view
@@ -3,23 +3,21 @@ -- specified type and shape. module Main (main) where -import Control.Arrow (first) import Control.Monad-import Control.Monad.State+import Control.Monad.ST import qualified Data.Binary as Bin-import qualified Data.ByteString.Lazy as BS-import Data.Binary.IEEE754-import Data.Binary.Put-import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Lazy.Char8 as BS import qualified Data.Map.Strict as M-import Data.List import qualified Data.Text as T import Data.Word+import qualified Data.Vector.Unboxed.Mutable as UMVec+import qualified Data.Vector.Unboxed as UVec+import Data.Vector.Generic (freeze) import System.Console.GetOpt import System.Random -import Language.Futhark.Syntax+import Language.Futhark.Syntax hiding (Value, PrimValue(..), IntValue(..), FloatValue(..)) import Language.Futhark.Attributes (UncheckedTypeExp, namesToPrimTypes) import Language.Futhark.Parser import Language.Futhark.Pretty ()@@ -38,7 +36,7 @@ case format config of Text -> mapM_ (putStrLn . pretty) vs Binary -> mapM_ (BS.putStr . Bin.encode) vs- Type -> mapM_ (putStrLn . valueType) vs+ Type -> mapM_ (putStrLn . pretty . valueType) vs | otherwise = Just $ zipWithM_ ($) (optOrders config) $ map mkStdGen [optSeed config..] f _ _ =@@ -124,121 +122,37 @@ where name = tname ++ "-bounds" tryMakeGenerator :: String -> Either String (RandomConfiguration -> OutputFormat -> StdGen -> IO ())-tryMakeGenerator t = do- t' <- toSimpleType =<< either (Left . show) Right (parseType name (T.pack t))+tryMakeGenerator t+ | Just vs <- readValues $ BS.pack t =+ return $ \_ fmt _ -> mapM_ (putValue fmt) vs+ | otherwise = do+ t' <- toValueType =<< either (Left . show) Right (parseType name (T.pack t)) return $ \conf fmt stdgen -> do let (v, _) = randomValue conf t' stdgen- case fmt of- Text -> printSimpleValueT v- Binary -> printSimpleValueB t' v- Type -> putStrLn t+ putValue fmt v where name = "option " ++ t--data SimpleType = SimpleArray SimpleType Int- | SimplePrim PrimType- deriving (Show)+ putValue Text = putStrLn . pretty+ putValue Binary = BS.putStr . Bin.encode+ putValue Type = putStrLn . pretty . valueType -toSimpleType :: UncheckedTypeExp -> Either String SimpleType-toSimpleType TETuple{} = Left "Cannot handle tuples yet."-toSimpleType TERecord{} = Left "Cannot handle records yet."-toSimpleType TEApply{} = Left "Cannot handle type applications yet."-toSimpleType TEArrow{} = Left "Cannot generate functions."-toSimpleType (TEUnique t _) = toSimpleType t-toSimpleType (TEArray t d _) =- SimpleArray <$> toSimpleType t <*> constantDim d+toValueType :: UncheckedTypeExp -> Either String ValueType+toValueType TETuple{} = Left "Cannot handle tuples yet."+toValueType TERecord{} = Left "Cannot handle records yet."+toValueType TEApply{} = Left "Cannot handle type applications yet."+toValueType TEArrow{} = Left "Cannot generate functions."+toValueType TEEnum{} = Left "Cannot handle enums yet."+toValueType (TEUnique t _) = toValueType t+toValueType (TEArray t d _) = do+ d' <- constantDim d+ ValueType ds t' <- toValueType t+ return $ ValueType (d':ds) t' where constantDim (ConstDim k) = Right k constantDim _ = Left "Array has non-constant dimension declaration."-toSimpleType (TEVar (QualName [] v) _)- | Just t <- M.lookup v namesToPrimTypes = Right $ SimplePrim t-toSimpleType (TEVar v _) =+toValueType (TEVar (QualName [] v) _)+ | Just t <- M.lookup v namesToPrimTypes = Right $ ValueType [] t+toValueType (TEVar v _) = Left $ "Unknown type " ++ pretty v -data SimpleValue = SimpleArrayValue [SimpleValue]- | SimplePrimValue PrimValue- deriving (Show)---- Ordinary prettyprinting consumes too much memory, likely because it--- manifests the string to print instead of doing it lazily, which is--- a bad idea for giant values. This is likely because it tries to do--- a good job with respect to line wrapping and the like. We opt to--- do a bad job instead, but one that we can do much faster.-printSimpleValueT :: SimpleValue -> IO ()-printSimpleValueT = (>>putStrLn "") . flip evalStateT 0 . p- where elements_per_line = 20 :: Int-- p (SimplePrimValue v) = do- maybeNewline- lift $ putStr $ pretty v- p (SimpleArrayValue []) =- lift $ putStr "[]"- p (SimpleArrayValue (v:vs)) = do- lift $ putStr "["- p v- forM_ vs $ \v' -> do- lift $ putStr ", "- p v'- lift $ putStr "]"-- maybeNewline = do- i <- get- if i >= elements_per_line- then do lift $ putStrLn ""- put 0- else put $ i + 1--binaryFormatVersion :: Int-binaryFormatVersion = 2--printSimpleValueB :: SimpleType -> SimpleValue -> IO ()-printSimpleValueB st sv =- BL.putStr $ runPut $ printHeader >> pSimpleValue sv-- where- printHeader = do- Bin.put 'b'- putWord8 $ fromIntegral binaryFormatVersion- let dims = getDims st- putWord8 $ fromIntegral $ length dims- putElemType st- case sv of- SimplePrimValue _ -> return ()- SimpleArrayValue _ -> mapM_ (putWord64le . fromIntegral) dims-- -- Simply calling @Bin.put (" i8" :: String)@ would cause a lot of bytes to- -- be written. Doing it this way will only write 4 bytes.- putElemType (SimplePrim (Signed Int8)) = mapM_ Bin.put (" i8" :: String)- putElemType (SimplePrim (Signed Int16)) = mapM_ Bin.put (" i16" :: String)- putElemType (SimplePrim (Signed Int32)) = mapM_ Bin.put (" i32" :: String)- putElemType (SimplePrim (Signed Int64)) = mapM_ Bin.put (" i64" :: String)- putElemType (SimplePrim (Unsigned Int8)) = mapM_ Bin.put (" u8" :: String)- putElemType (SimplePrim (Unsigned Int16)) = mapM_ Bin.put (" u16" :: String)- putElemType (SimplePrim (Unsigned Int32)) = mapM_ Bin.put (" u32" :: String)- putElemType (SimplePrim (Unsigned Int64)) = mapM_ Bin.put (" u64" :: String)- putElemType (SimplePrim (FloatType Float32)) = mapM_ Bin.put (" f32" :: String)- putElemType (SimplePrim (FloatType Float64)) = mapM_ Bin.put (" f64" :: String)- putElemType (SimplePrim Bool) = mapM_ Bin.put ("bool" :: String)- putElemType (SimpleArray ty _) = putElemType ty-- getDims (SimplePrim _) = []- getDims (SimpleArray ty dim) = dim : getDims ty-- pSimpleValue :: SimpleValue -> Put- pSimpleValue (SimplePrimValue pv) = p pv- pSimpleValue (SimpleArrayValue svs) = mapM_ pSimpleValue svs-- p :: PrimValue -> Put- p (SignedValue (Int8Value v)) = putWord8 $ fromIntegral $ fromEnum v- p (SignedValue (Int16Value v)) = putWord16le $ fromIntegral $ fromEnum v- p (SignedValue (Int32Value v)) = putWord32le $ fromIntegral $ fromEnum v- p (SignedValue (Int64Value v)) = putWord64le $ fromIntegral $ fromEnum v- p (UnsignedValue (Int8Value v)) = putWord8 $ fromIntegral $ fromEnum v- p (UnsignedValue (Int16Value v)) = putWord16le $ fromIntegral $ fromEnum v- p (UnsignedValue (Int32Value v)) = putWord32le $ fromIntegral $ fromEnum v- p (UnsignedValue (Int64Value v)) = putWord64le $ fromIntegral $ fromEnum v- p (FloatValue (Float32Value v)) = putFloat32le v- p (FloatValue (Float64Value v)) = putFloat64le v- p (BoolValue v) = putWord8 $ if v then 1 else 0- -- | Closed interval, as in @System.Random@. type Range a = (a, a) @@ -286,63 +200,39 @@ (minBound, maxBound) (minBound, maxBound) (minBound, maxBound) (minBound, maxBound) (0.0, 1.0) (0.0, 1.0) -randomValue :: RandomConfiguration -> SimpleType -> StdGen -> (SimpleValue, StdGen)-randomValue conf (SimplePrim (Signed Int8)) stdgen =- randomC conf i8Range stdgen-randomValue conf (SimplePrim (Signed Int16)) stdgen =- randomC conf i16Range stdgen-randomValue conf (SimplePrim (Signed Int32)) stdgen =- randomC conf i32Range stdgen-randomValue conf (SimplePrim (Signed Int64)) stdgen =- randomC conf i64Range stdgen--randomValue conf (SimplePrim (Unsigned Int8)) stdgen =- randomC conf u8Range stdgen-randomValue conf (SimplePrim (Unsigned Int16)) stdgen =- randomC conf u16Range stdgen-randomValue conf (SimplePrim (Unsigned Int32)) stdgen =- randomC conf u32Range stdgen-randomValue conf (SimplePrim (Unsigned Int64)) stdgen =- randomC conf u64Range stdgen--randomValue _ (SimplePrim Bool) stdgen =- first (SimplePrimValue . BoolValue) $ random stdgen--randomValue conf (SimplePrim (FloatType Float32)) stdgen =- randomC conf f32Range stdgen-randomValue conf (SimplePrim (FloatType Float64)) stdgen =- randomC conf f64Range stdgen--randomValue conf (SimpleArray t d) stdgen =- first SimpleArrayValue $ uncurry (flip (,)) $- mapAccumL f stdgen [0..d-1]- where f stdgen' _ = uncurry (flip (,)) $ randomValue conf t stdgen'--class ToFuthark a where- toFuthark :: a -> SimpleValue--instance ToFuthark Int8 where- toFuthark = SimplePrimValue . SignedValue . Int8Value-instance ToFuthark Int16 where- toFuthark = SimplePrimValue . SignedValue . Int16Value-instance ToFuthark Int32 where- toFuthark = SimplePrimValue . SignedValue . Int32Value-instance ToFuthark Int64 where- toFuthark = SimplePrimValue . SignedValue . Int64Value-instance ToFuthark Word8 where- toFuthark = SimplePrimValue . UnsignedValue . Int8Value . fromIntegral-instance ToFuthark Word16 where- toFuthark = SimplePrimValue . UnsignedValue . Int16Value . fromIntegral-instance ToFuthark Word32 where- toFuthark = SimplePrimValue . UnsignedValue . Int32Value . fromIntegral-instance ToFuthark Word64 where- toFuthark = SimplePrimValue . UnsignedValue . Int64Value . fromIntegral-instance ToFuthark Float where- toFuthark = SimplePrimValue . FloatValue . Float32Value-instance ToFuthark Double where- toFuthark = SimplePrimValue . FloatValue . Float64Value+randomValue :: RandomConfiguration -> ValueType -> StdGen -> (Value, StdGen)+randomValue conf (ValueType ds t) stdgen =+ case t of+ Signed Int8 -> gen i8Range Int8Value+ Signed Int16 -> gen i16Range Int16Value+ Signed Int32 -> gen i32Range Int32Value+ Signed Int64 -> gen i64Range Int64Value+ Unsigned Int8 -> gen u8Range Word8Value+ Unsigned Int16 -> gen u16Range Word16Value+ Unsigned Int32 -> gen u32Range Word32Value+ Unsigned Int64 -> gen u64Range Word64Value+ FloatType Float32 -> gen f32Range Float32Value+ FloatType Float64 -> gen f64Range Float64Value+ Bool -> gen (const (False,True)) BoolValue+ where gen range final = randomVector (range conf) final ds stdgen -randomC :: (ToFuthark a, Random a) =>- RandomConfiguration -> (RandomConfiguration -> Range a) -> StdGen- -> (SimpleValue, StdGen)-randomC conf pick = first toFuthark . randomR (pick conf)+randomVector :: (UMVec.Unbox v, Random v) =>+ Range v+ -> (UVec.Vector Int -> UVec.Vector v -> Value)+ -> [Int] -> StdGen+ -> (Value, StdGen)+randomVector range final ds stdgen = runST $ do+ -- USe some nice impure computation where we can preallocate a+ -- vector of the desired size, populate it via the random number+ -- generator, and then finally reutrn a frozen binary vector.+ arr <- UMVec.new n+ let fill stdgen' i+ | i < n = do+ let (v, stdgen'') = randomR range stdgen'+ UMVec.write arr i v+ fill stdgen'' $! i+1+ | otherwise = do+ arr' <- final (UVec.fromList ds) <$> freeze arr+ return (arr', stdgen')+ fill stdgen 0+ where n = product ds
src/futhark.hs view
@@ -323,7 +323,10 @@ -- | Entry point. Non-interactive, except when reading interpreter -- input from standard input. main :: IO ()-main = mainWithOptions newConfig commandLineOptions "options... program" compile+main = do+ hSetEncoding stdout utf8+ hSetEncoding stderr utf8+ mainWithOptions newConfig commandLineOptions "options... program" compile where compile [file] config = Just $ do res <- runFutharkM (m file config) $
src/futharki.hs view
@@ -199,10 +199,12 @@ return (imports, src', tenv, ienv') Just file -> do- (_, imports, src) <-+ (ws, imports, src) <- badOnLeft =<< liftIO (runExceptT (readProgram file) `Haskeline.catch` \(err::IOException) -> return (Left (ExternalError (T.pack $ show err))))+ liftIO $ hPrint stderr ws+ let imp = T.mkInitialImport "." ienv1 <- foldM (\ctx -> badOnLeft <=< runInterpreter' . I.interpretImport ctx) I.initialCtx $ map (fmap fileProg) imports@@ -232,7 +234,7 @@ return $ "[" ++ show i ++ "]> " mkOpen :: FilePath -> UncheckedDec-mkOpen f = OpenDec (ModImport f NoInfo noLoc) NoInfo noLoc+mkOpen f = OpenDec (ModImport f NoInfo noLoc) noLoc -- The ExceptT part is more of a continuation, really. newtype FutharkiM a =@@ -318,7 +320,7 @@ (imports, src, tenv, ienv) <- getIt case showErr (T.checkExp imports src tenv e) of Left err -> liftIO $ putStrLn err- Right e' -> do+ Right (_, e') -> do r <- runInterpreter $ I.interpretExp ienv e' case r of Left err -> liftIO $ print err@@ -392,7 +394,9 @@ (tenv, _) <- gets futharkiEnv case T.checkExp imports src tenv e' of Left err -> liftIO $ print err- Right e'' -> liftIO $ putStrLn $ pretty e' <> " : " <> pretty (typeOf e'')+ Right (ps, e'') -> liftIO $ putStrLn $+ pretty e' <> concatMap ((" "<>) . pretty) ps <>+ " : " <> pretty (typeOf e'') unbreakCommand :: Command unbreakCommand _ = do