Commit faa4b3f0 authored by chak@cse.unsw.edu.au.'s avatar chak@cse.unsw.edu.au.

Fix name generation for vectorised identifiers

parent 82ac7ff3
......@@ -42,13 +42,13 @@ module Name (
mkFCallName, mkIPName,
mkTickBoxOpName,
mkExternalName, mkWiredInName,
mkLocalisedOccName,
-- ** Manipulating and deconstructing 'Name's
nameUnique, setNameUnique,
nameOccName, nameModule, nameModule_maybe,
tidyNameOcc,
hashName, localiseName,
mkLocalisedOccName,
nameSrcLoc, nameSrcSpan, pprNameLoc,
......@@ -332,11 +332,12 @@ localiseName n = n { n_sort = Internal }
--
-- If the name is external, encode the original's module name to disambiguate.
--
mkLocalisedOccName :: (Maybe String -> OccName -> OccName) -> Name -> OccName
mkLocalisedOccName mk_occ name = mk_occ origin (nameOccName name)
mkLocalisedOccName :: Module -> (Maybe String -> OccName -> OccName) -> Name -> OccName
mkLocalisedOccName this_mod mk_occ name = mk_occ origin (nameOccName name)
where
origin | isExternalName name = Just (moduleNameColons . moduleName . nameModule $ name)
| otherwise = Nothing
origin
| nameIsLocalOrFrom this_mod name = Nothing
| otherwise = Just (moduleNameColons . moduleName . nameModule $ name)
\end{code}
%************************************************************************
......
......@@ -575,7 +575,8 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
mi_iface_hash = iface_hash,
mi_exp_hash = export_hash,
mi_orphan_hash = orphan_hash,
mi_orphan = not (null orph_rules && null orph_insts),
mi_orphan = not (null orph_rules && null orph_insts
&& null (ifaceVectInfoVar (mi_vect_info iface0))),
mi_finsts = not . null $ mi_fam_insts iface0,
mi_decls = sorted_decls,
mi_hash_fn = lookupOccEnv local_env }
......
......@@ -722,7 +722,7 @@ tcIfaceVectInfo mod typeEnv (IfaceVectInfo
}
where
vectVarMapping name
= do { vName <- lookupOrig mod (mkLocalisedOccName mkVectOcc name)
= do { vName <- lookupOrig mod (mkLocalisedOccName mod mkVectOcc name)
; var <- forkM (text ("vect var") <+> ppr name) $
tcIfaceExtId name
; vVar <- forkM (text ("vect vVar") <+> ppr vName) $
......@@ -730,9 +730,9 @@ tcIfaceVectInfo mod typeEnv (IfaceVectInfo
; return (var, (var, vVar))
}
vectTyConMapping name
= do { vName <- lookupOrig mod (mkLocalisedOccName mkVectTyConOcc name)
; paName <- lookupOrig mod (mkLocalisedOccName mkPADFunOcc name)
; isoName <- lookupOrig mod (mkLocalisedOccName mkVectIsoOcc name)
= do { vName <- lookupOrig mod (mkLocalisedOccName mod mkVectTyConOcc name)
; paName <- lookupOrig mod (mkLocalisedOccName mod mkPADFunOcc name)
; isoName <- lookupOrig mod (mkLocalisedOccName mod mkVectIsoOcc name)
-- FIXME: we will need to use tcIfaceTyCon/tcIfaceExtId on some of these (but depends
-- on how we exactly define the 'VECTORISE type' pragma to work)
; let { tycon = lookupTyCon name
......@@ -748,8 +748,8 @@ tcIfaceVectInfo mod typeEnv (IfaceVectInfo
)
}
vectTyConReuseMapping scalarNames name
= do { paName <- lookupOrig mod (mkLocalisedOccName mkPADFunOcc name)
; isoName <- lookupOrig mod (mkLocalisedOccName mkVectIsoOcc name)
= do { paName <- lookupOrig mod (mkLocalisedOccName mod mkPADFunOcc name)
; isoName <- lookupOrig mod (mkLocalisedOccName mod mkVectIsoOcc name)
; tycon <- forkM (text ("vect reuse tycon") <+> ppr name) $
tcIfaceTyCon (IfaceTc name) -- somewhat naughty for wired in tycons, but ok
; if name `elemNameSet` scalarNames
......@@ -773,7 +773,7 @@ tcIfaceVectInfo mod typeEnv (IfaceVectInfo
}}
vectDataConMapping datacon
= do { let name = dataConName datacon
; vName <- lookupOrig mod (mkLocalisedOccName mkVectDataConOcc name)
; vName <- lookupOrig mod (mkLocalisedOccName mod mkVectDataConOcc name)
; let vDataCon = lookupDataCon vName
; return (name, (datacon, vDataCon))
}
......
......@@ -32,10 +32,16 @@ import Control.Monad
-- always an internal system name.
--
mkLocalisedName :: (Maybe String -> OccName -> OccName) -> Name -> VM Name
mkLocalisedName mk_occ name = liftM make (liftDs newUnique)
where
occ_name = mkLocalisedOccName mk_occ name
make u = mkSystemName u occ_name
mkLocalisedName mk_occ name =
do { mod <- liftDs getModuleDs
; u <- liftDs newUnique
; let occ_name = mkLocalisedOccName mod mk_occ name
new_name | isExternalName name = mkExternalName u mod occ_name (nameSrcSpan name)
| otherwise = mkSystemName u occ_name
; return new_name
}
-- |Produce the vectorised variant of an `Id` with the given type.
--
......
......@@ -13,20 +13,21 @@ import BasicTypes
import CoreSyn
import CoreUtils
import CoreUnfold
import DsMonad
import TyCon
import Type
import TypeRep
import Id
import Var
import Name
-- import FastString
-- import Outputable
-- debug = False
-- dtrace s x = if debug then pprTrace "Vectoris.Type.PADict" s x else x
-- | Build the PA dictionary function for some type and hoist it to top level.
-- The PA dictionary holds fns that convert values to and from their vectorised representations.
-- |Build the PA dictionary function for some type and hoist it to top level.
--
-- The PA dictionary holds fns that convert values to and from their vectorised representations.
--
buildPADict
:: TyCon -- ^ tycon of the type being vectorised.
-> TyCon -- ^ tycon of the type used for the vectorised representation.
......@@ -55,51 +56,54 @@ buildPADict vect_tc prepr_tc arr_tc repr
-- abstract over; and they are put in the
-- envt, so when we need a (PA a) we can
-- find it in the envt
do -- Get ids for each of the methods in the dictionary, including superclass
method_ids <- mapM (method args) buildPAScAndMethods
do { mod <- liftDs getModuleDs
; let dfun_name = mkLocalisedOccName mod mkPADFunOcc vect_tc_name
-- Get ids for each of the methods in the dictionary, including superclass
; method_ids <- mapM (method args dfun_name) buildPAScAndMethods
-- Expression to build the dictionary.
pa_dc <- builtin paDataCon
let dict = mkLams (tvs ++ args)
$ mkConApp pa_dc
$ Type inst_ty
: map (method_call args) method_ids
-- Expression to build the dictionary.
; pa_dc <- builtin paDataCon
; let dict = mkLams (tvs ++ args)
$ mkConApp pa_dc
$ Type inst_ty
: map (method_call args) method_ids
-- Build the type of the dictionary function.
pa_cls <- builtin paClass
let dfun_ty = mkForAllTys tvs
$ mkFunTys (map varType args)
(PredTy $ ClassP pa_cls [inst_ty])
-- Build the type of the dictionary function.
; pa_cls <- builtin paClass
; let dfun_ty = mkForAllTys tvs
$ mkFunTys (map varType args)
(PredTy $ ClassP pa_cls [inst_ty])
-- Set the unfolding for the inliner.
raw_dfun <- newExportedVar dfun_name dfun_ty
let dfun_unf = mkDFunUnfolding dfun_ty $
map Var method_ids
dfun = raw_dfun `setIdUnfolding` dfun_unf
`setInlinePragma` dfunInlinePragma
-- Set the unfolding for the inliner.
; raw_dfun <- newExportedVar dfun_name dfun_ty
; let dfun_unf = mkDFunUnfolding dfun_ty $
map Var method_ids
dfun = raw_dfun `setIdUnfolding` dfun_unf
`setInlinePragma` dfunInlinePragma
-- Add the new binding to the top-level environment.
hoistBinding dfun dict
return dfun
-- Add the new binding to the top-level environment.
; hoistBinding dfun dict
; return dfun
}
where
tvs = tyConTyVars vect_tc
arg_tys = mkTyVarTys tvs
inst_ty = mkTyConApp vect_tc arg_tys
vect_tc_name = getName vect_tc
dfun_name = mkLocalisedOccName mkPADFunOcc vect_tc_name
method args (name, build)
method args dfun_name (name, build)
= localV
$ do
expr <- build vect_tc prepr_tc arr_tc repr
let body = mkLams (tvs ++ args) expr
raw_var <- newExportedVar (method_name name) (exprType body)
raw_var <- newExportedVar (method_name dfun_name name) (exprType body)
let var = raw_var
`setIdUnfolding` mkInlineUnfolding (Just (length args)) body
`setInlinePragma` alwaysInlinePragma
hoistBinding var body
return var
method_call args id = mkApps (Var id) (map Type arg_tys ++ map Var args)
method_name name = mkVarOcc $ occNameString dfun_name ++ ('$' : name)
method_call args id = mkApps (Var id) (map Type arg_tys ++ map Var args)
method_name dfun_name name = mkVarOcc $ occNameString dfun_name ++ ('$' : name)
Markdown is supported
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