Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
head.hackage
Commits
a300c60a
Commit
a300c60a
authored
May 11, 2022
by
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
Changes
1
Pipelines
31
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 +30
8
,10 @@
optimiseLoopBySwitching (Pat pes) merge (Body _ body_stms body_res) = do
@@ -308,6 +30
9
,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 +41
7
,17 @@
doubleBufferMergeParams ctx_and_res bound_in_loop =
@@ -413,12 +41
8
,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
}
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment