import Var
import VarEnv
import VarSet
-import Name ( mkSysTvName, getName )
+import Name ( Name, mkSysTvName, getName )
import NameEnv
import Id
import MkId ( unwrapFamInstScrut )
import OccName
+import RdrName ( RdrName, mkRdrQual )
+import Module ( mkModuleNameFS )
import DsMonad hiding (mapAndUnzipM)
import DsUtils ( mkCoreTup, mkCoreTupTy )
import FastString
import Control.Monad ( liftM, liftM2, zipWithM, mapAndUnzipM )
+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 = [
+ mk closureTyConName FSLIT("dPA_Clo")
+ , 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 hsc_env _ _ guts
vectModule :: ModGuts -> VM ModGuts
vectModule guts
= do
- (types', fam_insts, pa_insts) <- vectTypeEnv (mg_types guts)
+ defTyConRdrPAs builtin_PAs
+ (types', fam_insts, tc_binds) <- vectTypeEnv (mg_types guts)
- let insts = map painstInstance pa_insts
- fam_inst_env' = extendFamInstEnvList (mg_fam_inst_env guts) fam_insts
- inst_env' = extendInstEnvList (mg_inst_env guts) insts
- updGEnv (setInstEnvs inst_env' fam_inst_env')
+ let fam_inst_env' = extendFamInstEnvList (mg_fam_inst_env guts) fam_insts
+ updGEnv (setFamInstEnv fam_inst_env')
- dicts <- mapM buildPADict pa_insts
- binds' <- mapM vectTopBind (mg_binds guts)
+ -- dicts <- mapM buildPADict pa_insts
+ -- workers <- mapM vectDataConWorkers pa_insts
+ binds' <- mapM vectTopBind (mg_binds guts)
return $ guts { mg_types = types'
- , mg_binds = Rec (concat dicts) : binds'
- , mg_inst_env = inst_env'
+ , mg_binds = Rec tc_binds : binds'
, mg_fam_inst_env = fam_inst_env'
- , mg_insts = mg_insts guts ++ insts
, mg_fam_insts = mg_fam_insts guts ++ fam_insts
}
vectTopBinder :: Var -> VM Var
vectTopBinder var
= do
- vty <- vectType (idType var)
- name <- cloneName mkVectOcc (getName var)
- let var' | isExportedId var = Id.mkExportedLocalId name vty
- | otherwise = Id.mkLocalId name vty
+ vty <- vectType (idType var)
+ var' <- cloneId mkVectOcc var vty
defGlobalVar var var'
return var'