Skip to content

GitLab

Commit a300c60a authored by Matthew Pickering's avatar Matthew Pickering
Browse files

Patch futhark for !7981 (Typecheck record update via desugaring in tcExpr)

parent b670f1c5
Pipeline #52592 failed with stages
in 1 minute and 38 seconds
Hide whitespace changes
Inline Side-by-side
patches/futhark-0.21.10.patch
View file @ a300c60a
diff --git a/src/Futhark/Analysis/CallGraph.hs b/src/Futhark/Analysis/CallGraph.hs
index 025cf8b..44ed2aa 100644
--- a/src/Futhark/Analysis/CallGraph.hs
+++ b/src/Futhark/Analysis/CallGraph.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
-- | This module exports functionality for generating a call graph of
-- an Futhark program.
@@ -135,7 +136,7 @@ buildFGstm (Let _ _ (Op op)) = execWriter $ mapSOACM folder op
buildFGstm (Let _ _ e) = execWriter $ mapExpM folder e
where
folder =
- identityMapper
+ (identityMapper @_ @SOACS)
{ mapOnBody = \_ body -> do
tell $ buildFGBody body
pure body
@@ -155,7 +156,7 @@ findNoninlined prog =
onStm (Let _ _ e) = execWriter $ mapExpM folder e
where
folder =
- identityMapper
+ (identityMapper @_ @SOACS)
{ mapOnBody = \_ body -> do
tell $ foldMap onStm $ bodyStms body
pure body,
diff --git a/src/Futhark/IR/Mem.hs b/src/Futhark/IR/Mem.hs
index d938b9e..4367778 100644
--- a/src/Futhark/IR/Mem.hs
......@@ -42,6 +70,36 @@ index d938b9e..4367778 100644
inputReturns (_, arrs, _) = mapM varReturns arrs
num_accs = length inputs
diff --git a/src/Futhark/IR/SOACS/Simplify.hs b/src/Futhark/IR/SOACS/Simplify.hs
index 19a3398..d2e1a6f 100644
--- a/src/Futhark/IR/SOACS/Simplify.hs
+++ b/src/Futhark/IR/SOACS/Simplify.hs
@@ -3,6 +3,7 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Futhark.IR.SOACS.Simplify
@@ -741,7 +742,7 @@ arrayOps = mconcat . map onStm . stmsToList . bodyStms
tell $ arrayOps $ lambdaBody lam
pure lam
walker =
- identityWalker
+ (identityWalker @_ @rep)
{ walkOnBody = const $ modify . (<>) . arrayOps,
walkOnOp = modify . (<>) . onOp
}
@@ -764,7 +765,7 @@ replaceArrayOps substs (Body _ stms res) =
fromArrayOp op'
onExp _ cs e = (cs, mapExp mapper e)
mapper =
- identityMapper
+ (identityMapper @_ @rep)
{ mapOnBody = const $ pure . replaceArrayOps substs,
mapOnOp = pure . onOp
}
diff --git a/src/Futhark/IR/SegOp.hs b/src/Futhark/IR/SegOp.hs
index 6b3af1d..2a1128d 100644
--- a/src/Futhark/IR/SegOp.hs
......@@ -61,11 +119,59 @@ index 6b3af1d..2a1128d 100644
correct (WriteReturns _ _ arr _) _ = varReturns arr
correct _ ret = pure ret
diff --git a/src/Futhark/Optimise/CSE.hs b/src/Futhark/Optimise/CSE.hs
index e621dd9..1809ac7 100644
--- a/src/Futhark/Optimise/CSE.hs
+++ b/src/Futhark/Optimise/CSE.hs
@@ -2,6 +2,8 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
-- | This module implements common-subexpression elimination. This
-- module does not actually remove the duplicate, but only replaces
@@ -181,7 +183,7 @@ cseInLambda lam = do
pure lam {lambdaBody = body'}
cseInStms ::
- (ASTRep rep, Aliased rep, CSEInOp (Op rep)) =>
+ forall rep a . (ASTRep rep, Aliased rep, CSEInOp (Op rep)) =>
Names ->
[Stm rep] ->
CSEM rep a ->
@@ -204,7 +206,7 @@ cseInStms consumed (stm : stms) m =
pure stm' {stmExp = e}
cse ds =
- identityMapper
+ (identityMapper @_ @rep)
{ mapOnBody = const $ cseInBody ds,
mapOnOp = cseInOp
}
diff --git a/src/Futhark/Optimise/DoubleBuffer.hs b/src/Futhark/Optimise/DoubleBuffer.hs
index b898aa4..e98e5ca 100644
index b898aa4..631cf39 100644
--- a/src/Futhark/Optimise/DoubleBuffer.hs
+++ b/src/Futhark/Optimise/DoubleBuffer.hs
@@ -259,7 +259,7 @@ isArrayIn :: VName -> Param FParamMem -> Bool
@@ -5,6 +5,7 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeApplications #-}
-- | The simplification engine is only willing to hoist allocations
-- out of loops if the memory block resulting from the allocation is
@@ -176,7 +177,7 @@ optimiseStm (Let pat aux e) = do
oneStm . Let pat aux <$> mapExpM (optimise onOp) e
where
optimise onOp =
- identityMapper
+ (identityMapper @_ @rep)
{ mapOnBody = \_ x ->
optimiseBody x :: DoubleBufferM rep (Body rep),
mapOnOp = onOp
@@ -259,7 +260,7 @@ isArrayIn :: VName -> Param FParamMem -> Bool
isArrayIn x (Param _ _ (MemArray _ _ _ (ArrayIn y _))) = x == y
isArrayIn _ _ = False
......@@ -74,7 +180,7 @@ index b898aa4..e98e5ca 100644
optimiseLoopBySwitching (Pat pes) merge (Body _ body_stms body_res) = do
((pat', merge', body'), outer_stms) <- runBuilder $ do
((buffered, body_stms'), (pes', merge', body_res')) <-
@@ -308,6 +308,10 @@ optimiseLoopBySwitching (Pat pes) merge (Body _ body_stms body_res) = do
@@ -308,6 +309,10 @@ optimiseLoopBySwitching (Pat pes) merge (Body _ body_stms body_res) = do
([pe], [(param, arg)], [res])
)
......@@ -85,7 +191,7 @@ index b898aa4..e98e5ca 100644
maybeCopyInitial buffered (param@(Param _ _ (MemArray _ _ _ (ArrayIn mem _))), Var arg)
| Just mem' <- mem `M.lookup` buffered = do
arg_info <- lookupMemInfo arg
@@ -413,12 +417,17 @@ doubleBufferMergeParams ctx_and_res bound_in_loop =
@@ -413,12 +418,17 @@ doubleBufferMergeParams ctx_and_res bound_in_loop =
_ -> pure NoBuffer
allocStms ::
......@@ -103,6 +209,287 @@ index b898aa4..e98e5ca 100644
allocation m@(Param attrs pname _, _) (BufferAlloc name size space b) = do
stms <- lift $
runBuilder_ $ do
diff --git a/src/Futhark/Optimise/Fusion.hs b/src/Futhark/Optimise/Fusion.hs
index e96f68d..5d9079b 100644
--- a/src/Futhark/Optimise/Fusion.hs
+++ b/src/Futhark/Optimise/Fusion.hs
@@ -2,6 +2,7 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeApplications #-}
-- | Perform horizontal and vertical fusion of SOACs. See the paper
-- /A T2 Graph-Reduction Approach To Fusion/ for the basic idea (some
@@ -917,7 +918,7 @@ fuseInExp e = mapExpM fuseIn e
fuseIn :: Mapper SOACS SOACS FusionGM
fuseIn =
- identityMapper
+ (identityMapper @_ @SOACS)
{ mapOnBody = const fuseInBody,
mapOnOp = mapSOACM identitySOACMapper {mapOnSOACLambda = fuseInLambda}
}
diff --git a/src/Futhark/Optimise/InPlaceLowering.hs b/src/Futhark/Optimise/InPlaceLowering.hs
index 65cefed..479dd08 100644
--- a/src/Futhark/Optimise/InPlaceLowering.hs
+++ b/src/Futhark/Optimise/InPlaceLowering.hs
@@ -4,6 +4,8 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}
-- | This module implements an optimisation that moves in-place
@@ -188,7 +190,7 @@ optimiseInStm :: Constraints rep => Stm (Aliases rep) -> ForwardingM rep (Stm (A
optimiseInStm (Let pat dec e) =
Let pat dec <$> optimiseExp e
-optimiseExp :: Constraints rep => Exp (Aliases rep) -> ForwardingM rep (Exp (Aliases rep))
+optimiseExp :: forall rep . Constraints rep => Exp (Aliases rep) -> ForwardingM rep (Exp (Aliases rep))
optimiseExp (DoLoop merge form body) =
bindingScope (scopeOf form) . bindingFParams (map fst merge) $
DoLoop merge form <$> optimiseBody body
@@ -198,7 +200,7 @@ optimiseExp (Op op) = do
optimiseExp e = mapExpM optimise e
where
optimise =
- identityMapper
+ (identityMapper @_ @(Aliases rep))
{ mapOnBody = const optimiseBody
}
@@ -379,14 +381,14 @@ isOptimisable name = do
++ pretty name
++ " not found."
-seenVar :: VName -> ForwardingM rep ()
+seenVar :: forall rep . VName -> ForwardingM rep ()
seenVar name = do
aliases <-
asks $
maybe mempty entryAliases
. M.lookup name
. topDownTable
- tell $ mempty {bottomUpSeen = oneName name <> aliases}
+ tell $ (mempty @(BottomUp rep)) {bottomUpSeen = oneName name <> aliases}
tapBottomUp :: ForwardingM rep a -> ForwardingM rep (a, BottomUp rep)
tapBottomUp m = do
diff --git a/src/Futhark/Optimise/InPlaceLowering/SubstituteIndices.hs b/src/Futhark/Optimise/InPlaceLowering/SubstituteIndices.hs
index f90c04e..8387afe 100644
--- a/src/Futhark/Optimise/InPlaceLowering/SubstituteIndices.hs
+++ b/src/Futhark/Optimise/InPlaceLowering/SubstituteIndices.hs
@@ -1,5 +1,7 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ScopedTypeVariables #-}
-- | This module exports facilities for transforming array accesses in
-- a list of 'Stm's (intended to be the bindings in a body). The
@@ -87,7 +89,7 @@ substituteIndicesInStm substs (Let pat rep e) = do
addStm $ Let pat rep e'
pure substs
-substituteIndicesInExp ::
+substituteIndicesInExp :: forall m .
(MonadBuilder m, Buildable (Rep m), Aliased (Rep m)) =>
IndexSubstitutions ->
Exp (Rep m) ->
@@ -105,7 +107,7 @@ substituteIndicesInExp substs (Op op) = do
substituteIndicesInExp substs e = do
substs' <- copyAnyConsumed e
let substitute =
- identityMapper
+ (identityMapper @_ @(Rep m))
{ mapOnSubExp = substituteIndicesInSubExp substs',
mapOnVName = substituteIndicesInVar substs',
mapOnBody = const $ substituteIndicesInBody substs'
diff --git a/src/Futhark/Optimise/InliningDeadFun.hs b/src/Futhark/Optimise/InliningDeadFun.hs
index 84fe8ec..3c854c5 100644
--- a/src/Futhark/Optimise/InliningDeadFun.hs
+++ b/src/Futhark/Optimise/InliningDeadFun.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
-- | This module implements a compiler pass for inlining functions,
-- then removing those that have become dead.
@@ -209,7 +210,7 @@ inlineInBody fdmap = onBody
onStm (Let pat aux e) = Let pat aux <$> mapExpM inliner e
inliner =
- identityMapper
+ (identityMapper @_ @SOACS)
{ mapOnBody = const onBody,
mapOnOp = onSOAC
}
@@ -256,7 +257,7 @@ addLocations attrs caller_safety more_locs = fmap onStm
onExp =
mapExp
- identityMapper
+ (identityMapper @_ @SOACS)
{ mapOnBody = const $ pure . onBody attrs
}
diff --git a/src/Futhark/Optimise/Simplify/Rules.hs b/src/Futhark/Optimise/Simplify/Rules.hs
index 6fbad88..01da595 100644
--- a/src/Futhark/Optimise/Simplify/Rules.hs
+++ b/src/Futhark/Optimise/Simplify/Rules.hs
@@ -2,6 +2,8 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
-- | This module defines a collection of simplification rules, as per
-- "Futhark.Optimise.Simplify.Rule". They are used in the
@@ -386,7 +388,7 @@ withAccTopDown vtable (Let pat aux (WithAcc inputs lam)) = Simplify . auxing aux
pure $ Just x
withAccTopDown _ _ = Skip
-elimUpdates :: (ASTRep rep, TraverseOpStms rep) => [VName] -> Body rep -> (Body rep, [VName])
+elimUpdates :: forall rep . (ASTRep rep, TraverseOpStms rep) => [VName] -> Body rep -> (Body rep, [VName])
elimUpdates get_rid_of = flip runState mempty . onBody
where
onBody body = do
@@ -402,7 +404,7 @@ elimUpdates get_rid_of = flip runState mempty . onBody
onExp = mapExpM mapper
where
mapper =
- identityMapper
+ (identityMapper @_ @rep)
{ mapOnOp = traverseOpStms (\_ stms -> onStms stms),
mapOnBody = \_ body -> onBody body
}
diff --git a/src/Futhark/Optimise/Sink.hs b/src/Futhark/Optimise/Sink.hs
index 87235d2..38bcdae 100644
--- a/src/Futhark/Optimise/Sink.hs
+++ b/src/Futhark/Optimise/Sink.hs
@@ -1,6 +1,8 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
-- | "Sinking" is conceptually the opposite of hoisting. The idea is
-- to take code that looks like this:
@@ -103,7 +105,7 @@ optimiseBranch onOp vtable sinking (Body dec stms res) =
&& all (`ST.available` vtable) (namesToList (freeIn stm))
sunk = namesFromList $ foldMap (patNames . stmPat) sunk_stms
-optimiseStms ::
+optimiseStms :: forall rep .
Constraints rep =>
Sinker rep (Op rep) ->
SymbolTable rep ->
@@ -155,7 +157,7 @@ optimiseStms onOp init_vtable init_sinking all_stms free_in_res =
where
vtable' = ST.insertStm stm vtable
mapper =
- identityMapper
+ (identityMapper @_ @rep)
{ mapOnBody = \scope body -> do
let (body', sunk) =
optimiseBody
diff --git a/src/Futhark/Optimise/TileLoops.hs b/src/Futhark/Optimise/TileLoops.hs
index 4cbbc2a..8e957b2 100644
--- a/src/Futhark/Optimise/TileLoops.hs
+++ b/src/Futhark/Optimise/TileLoops.hs
@@ -1,6 +1,7 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeApplications #-}
-- | Perform a restricted form of loop tiling within SegMaps. We only
-- tile primitive types, to avoid excessive local memory use.
@@ -59,7 +60,8 @@ optimiseStm stm@(Let pat aux (Op (SegOp (SegMap lvl@SegThread {} space ts kbody)
optimiseStm (Let pat aux e) =
pure <$> (Let pat aux <$> mapExpM optimise e)
where
- optimise = identityMapper {mapOnBody = \scope -> localScope scope . optimiseBody}
+ optimise :: Mapper GPU GPU (ReaderT (Scope GPU) (State VNameSource))
+ optimise = (identityMapper @_ @GPU) {mapOnBody = \scope -> localScope scope . optimiseBody}
tileInKernelBody ::
Names ->
diff --git a/src/Futhark/Optimise/Unstream.hs b/src/Futhark/Optimise/Unstream.hs
index cbdaa08..338eac8 100644
--- a/src/Futhark/Optimise/Unstream.hs
+++ b/src/Futhark/Optimise/Unstream.hs
@@ -1,5 +1,7 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ScopedTypeVariables #-}
-- | Sequentialise any remaining SOACs. It is very important that
-- this is run *after* any access-pattern-related optimisation,
@@ -100,7 +102,7 @@ optimiseLambda onOp lam = localScope (scopeOfLParams $ lambdaParams lam) $ do
body <- optimiseBody onOp $ lambdaBody lam
pure lam {lambdaBody = body}
-optimiseStm ::
+optimiseStm :: forall rep .
ASTRep rep =>
OnOp rep ->
Stm rep ->
@@ -111,7 +113,7 @@ optimiseStm onOp (Let pat aux e) =
pure <$> (Let pat aux <$> mapExpM optimise e)
where
optimise =
- identityMapper
+ (identityMapper @_ @rep)
{ mapOnBody = \scope ->
localScope scope . optimiseBody onOp
}
diff --git a/src/Futhark/Pass/ExpandAllocations.hs b/src/Futhark/Pass/ExpandAllocations.hs
index 59f2fb7..6a87607 100644
--- a/src/Futhark/Pass/ExpandAllocations.hs
+++ b/src/Futhark/Pass/ExpandAllocations.hs
@@ -1,6 +1,7 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeApplications #-}
-- | Expand allocations inside of maps when possible.
module Futhark.Pass.ExpandAllocations (expandAllocations) where
@@ -107,7 +108,7 @@ transformStm (Let pat aux e) = do
pure $ stms <> oneStm (Let pat aux e')
where
transform =
- identityMapper
+ (identityMapper @_ @GPUMem)
{ mapOnBody = \scope -> localScope scope . transformBody
}
@@ -385,7 +386,7 @@ extractStmAllocations user bound_outside bound_kernel stm = do
pure $ Just $ stm {stmExp = e}
where
expMapper user' =
- identityMapper
+ (identityMapper @_ @GPUMem)
{ mapOnBody = const $ onBody user',
mapOnOp = onOp user'
}
@@ -691,7 +692,7 @@ offsetMemoryInExp (DoLoop merge form body) = do
offsetMemoryInExp e = mapExpM recurse e
where
recurse =
- identityMapper
+ (identityMapper @_ @GPUMem)
{ mapOnBody = \bscope -> localScope bscope . offsetMemoryInBody,
mapOnBranchType = offsetMemoryInBodyReturns,
mapOnOp = onOp
diff --git a/src/Futhark/Pass/ExplicitAllocations.hs b/src/Futhark/Pass/ExplicitAllocations.hs
index 351d1f3..37e7d28 100644
--- a/src/Futhark/Pass/ExplicitAllocations.hs
......@@ -271,3 +658,32 @@ index 41ed68b..1dec512 100644
(VName -> Maybe VName) ->
SeqLoop ->
LoopNesting ->
diff --git a/src/Futhark/Pass/KernelBabysitting.hs b/src/Futhark/Pass/KernelBabysitting.hs
index f152797..67052e0 100644
--- a/src/Futhark/Pass/KernelBabysitting.hs
+++ b/src/Futhark/Pass/KernelBabysitting.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeApplications #-}
-- | Do various kernel optimisations - mostly related to coalescing.
module Futhark.Pass.KernelBabysitting (babysitKernels) where
@@ -105,7 +106,7 @@ transformStm expmap (Let pat aux e) = do
transform :: ExpMap -> Mapper GPU GPU BabysitM
transform expmap =
- identityMapper {mapOnBody = \scope -> localScope scope . transformBody expmap}
+ (identityMapper @_ @GPU) {mapOnBody = \scope -> localScope scope . transformBody expmap}
transformKernelBody ::
ExpMap ->
@@ -212,7 +213,7 @@ traverseKernelBodyArrayIndexes free_ker_vars thread_variant outer_scope f (Kerne
onOp _ op = pure op
mapper ctx =
- identityMapper
+ (identityMapper @_ @GPU)
{ mapOnBody = const (onBody ctx),
mapOnOp = onOp ctx
}
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment