projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Added handling of non-recursive module global functions to isScalar check
[ghc-hetmet.git]
/
compiler
/
vectorise
/
Vectorise.hs
diff --git
a/compiler/vectorise/Vectorise.hs
b/compiler/vectorise/Vectorise.hs
index
8e04833
..
8c9579e
100644
(file)
--- a/
compiler/vectorise/Vectorise.hs
+++ b/
compiler/vectorise/Vectorise.hs
@@
-18,13
+18,14
@@
import CoreSyn
import CoreUnfold ( mkInlineUnfolding )
import CoreFVs
import CoreMonad ( CoreM, getHscEnv )
import CoreUnfold ( mkInlineUnfolding )
import CoreFVs
import CoreMonad ( CoreM, getHscEnv )
-import FamInstEnv ( extendFamInstEnvList )
import Var
import Id
import OccName
import BasicTypes ( isLoopBreaker )
import Outputable
import Util ( zipLazy )
import Var
import Id
import OccName
import BasicTypes ( isLoopBreaker )
import Outputable
import Util ( zipLazy )
+import MonadUtils
+
import Control.Monad
debug = False
import Control.Monad
debug = False
@@
-60,9
+61,7
@@
vectModule guts
-- TODO: What new binds do we get back here?
(types', fam_insts, tc_binds) <- vectTypeEnv (mg_types guts)
-- TODO: What new binds do we get back here?
(types', fam_insts, tc_binds) <- vectTypeEnv (mg_types guts)
- -- TODO: What is this?
- let fam_inst_env' = extendFamInstEnvList (mg_fam_inst_env guts) fam_insts
- updGEnv (setFamInstEnv fam_inst_env')
+ (_, fam_inst_env) <- readGEnv global_fam_inst_env
-- dicts <- mapM buildPADict pa_insts
-- workers <- mapM vectDataConWorkers pa_insts
-- dicts <- mapM buildPADict pa_insts
-- workers <- mapM vectDataConWorkers pa_insts
@@
-72,7
+71,7
@@
vectModule guts
return $ guts { mg_types = types'
, mg_binds = Rec tc_binds : binds'
return $ guts { mg_types = types'
, mg_binds = Rec tc_binds : binds'
- , mg_fam_inst_env = fam_inst_env'
+ , mg_fam_inst_env = fam_inst_env
, mg_fam_insts = mg_fam_insts guts ++ fam_insts
}
, mg_fam_insts = mg_fam_insts guts ++ fam_insts
}
@@
-168,7
+167,7
@@
vectTopBinder var inline expr
vty <- vectType (idType var)
-- Make the vectorised version of binding's name, and set the unfolding used for inlining.
vty <- vectType (idType var)
-- Make the vectorised version of binding's name, and set the unfolding used for inlining.
- var' <- liftM (`setIdUnfolding` unfolding)
+ var' <- liftM (`setIdUnfoldingLazily` unfolding)
$ cloneId mkVectOcc var vty
-- Add the mapping between the plain and vectorised name to the state.
$ cloneId mkVectOcc var vty
-- Add the mapping between the plain and vectorised name to the state.
@@
-190,9
+189,13
@@
vectTopRhs
vectTopRhs var expr
= dtrace (vcat [text "vectTopRhs", ppr expr])
$ closedV
vectTopRhs var expr
= dtrace (vcat [text "vectTopRhs", ppr expr])
$ closedV
- $ do (inline, vexpr) <- inBind var
+ $ do (inline, isScalar, vexpr) <- inBind var
+ $ pprTrace "vectTopRhs" (ppr var)
$ vectPolyExpr (isLoopBreaker $ idOccInfo var)
(freeVars expr)
$ vectPolyExpr (isLoopBreaker $ idOccInfo var)
(freeVars expr)
+ if isScalar
+ then addGlobalScalar var
+ else return ()
return (inline, vectorised vexpr)
return (inline, vectorised vexpr)