projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Change DataCon worker vectorisation to use PA records
[ghc-hetmet.git]
/
compiler
/
vectorise
/
Vectorise.hs
diff --git
a/compiler/vectorise/Vectorise.hs
b/compiler/vectorise/Vectorise.hs
index
39c6a23
..
07293be
100644
(file)
--- a/
compiler/vectorise/Vectorise.hs
+++ b/
compiler/vectorise/Vectorise.hs
@@
-46,11
+46,22
@@
import Outputable
import FastString
import Control.Monad ( liftM, liftM2, zipWithM, mapAndUnzipM )
import FastString
import Control.Monad ( liftM, liftM2, zipWithM, mapAndUnzipM )
-mkNDPVar :: FastString -> RdrName
-mkNDPVar fs = mkRdrQual nDP_BUILTIN (mkVarOccFS fs)
+mkNDPVar :: String -> RdrName
+mkNDPVar s = mkRdrQual nDP_BUILTIN (mkVarOcc s)
+
+mkNDPVarFS :: FastString -> RdrName
+mkNDPVarFS fs = mkRdrQual nDP_BUILTIN (mkVarOccFS fs)
builtin_PAs :: [(Name, RdrName)]
builtin_PAs :: [(Name, RdrName)]
-builtin_PAs = [(intTyConName, mkNDPVar FSLIT("dPA_Int"))]
+builtin_PAs = [
+ mk intTyConName FSLIT("dPA_Int")
+ ]
+ ++ tups
+ where
+ mk name fs = (name, mkNDPVarFS fs)
+
+ tups = mk_tup 0 : map mk_tup [2..3]
+ mk_tup n = (getName $ tupleTyCon Boxed n, mkNDPVar $ "dPA_" ++ show n)
vectorise :: HscEnv -> UniqSupply -> RuleBase -> ModGuts
-> IO (SimplCount, ModGuts)
vectorise :: HscEnv -> UniqSupply -> RuleBase -> ModGuts
-> IO (SimplCount, ModGuts)
@@
-69,7
+80,7
@@
vectModule :: ModGuts -> VM ModGuts
vectModule guts
= do
defTyConRdrPAs builtin_PAs
vectModule guts
= do
defTyConRdrPAs builtin_PAs
- (types', fam_insts) <- vectTypeEnv (mg_types guts)
+ (types', fam_insts, tc_binds) <- vectTypeEnv (mg_types guts)
let fam_inst_env' = extendFamInstEnvList (mg_fam_inst_env guts) fam_insts
updGEnv (setFamInstEnv fam_inst_env')
let fam_inst_env' = extendFamInstEnvList (mg_fam_inst_env guts) fam_insts
updGEnv (setFamInstEnv fam_inst_env')
@@
-78,8
+89,7
@@
vectModule guts
-- workers <- mapM vectDataConWorkers pa_insts
binds' <- mapM vectTopBind (mg_binds guts)
return $ guts { mg_types = types'
-- workers <- mapM vectDataConWorkers pa_insts
binds' <- mapM vectTopBind (mg_binds guts)
return $ guts { mg_types = types'
- , mg_binds = -- Rec (concat workers ++ concat dicts) :
- binds'
+ , mg_binds = Rec tc_binds : binds'
, mg_fam_inst_env = fam_inst_env'
, mg_fam_insts = mg_fam_insts guts ++ fam_insts
}
, mg_fam_inst_env = fam_inst_env'
, mg_fam_insts = mg_fam_insts guts ++ fam_insts
}