Skip to content

GitLab

GHC
GHC
Commit caff8eab authored by Ian Lynagh's avatar Ian Lynagh
Browse files
Options

Merge branch 'master' of http://darcs.haskell.org/ghc

parents a07ce419 3513b073
Expand all Hide whitespace changes
Inline Side-by-side
Showing with 367 additions and 304 deletions
compiler/cmm/CmmLive.hs
View file @ caff8eab
......@@ -6,7 +6,8 @@ module CmmLive
( CmmLive
, cmmLiveness
, liveLattice
, noLiveOnEntry, xferLive
, noLiveOnEntry, xferLive, gen, kill, gen_kill
, removeDeadAssignments
)
where
......@@ -65,13 +66,37 @@ gen_kill :: (DefinerOfLocalRegs a, UserOfLocalRegs a) => a -> CmmLive -> CmmLive
gen_kill a = gen a . kill a
-- | The transfer function
-- EZY: Bits of this analysis are duplicated in CmmSpillReload, though
-- it's not really easy to efficiently reuse all of this. Keep in mind
-- if you need to update this analysis.
xferLive :: BwdTransfer CmmNode CmmLive
xferLive = mkBTransfer3 fst mid lst
where fst _ f = f
mid :: CmmNode O O -> CmmLive -> CmmLive
mid n f = gen_kill n f
lst :: CmmNode O C -> FactBase CmmLive -> CmmLive
-- slightly inefficient: kill is unnecessary for emptyRegSet
lst n f = gen_kill n
$ case n of CmmCall{} -> emptyRegSet
CmmForeignCall{} -> emptyRegSet
_ -> joinOutFacts liveLattice n f
-----------------------------------------------------------------------------
-- Removing assignments to dead variables
-----------------------------------------------------------------------------
removeDeadAssignments :: CmmGraph -> FuelUniqSM CmmGraph
removeDeadAssignments g =
liftM fst $ dataflowPassBwd g [] $ analRewBwd liveLattice xferLive rewrites
where rewrites = deepBwdRw3 nothing middle nothing
-- Beware: deepBwdRw with one polymorphic function seems more reasonable here,
-- but GHC panics while compiling, see bug #4045.
middle :: CmmNode O O -> Fact O CmmLive -> CmmReplGraph O O
middle (CmmAssign (CmmLocal reg') _) live | not (reg' `elemRegSet` live) = return $ Just emptyGraph
-- XXX maybe this should be somewhere else...
middle (CmmAssign lhs (CmmReg rhs)) _ | lhs == rhs = return $ Just emptyGraph
middle (CmmStore lhs (CmmLoad rhs _)) _ | lhs == rhs = return $ Just emptyGraph
middle _ _ = return Nothing
nothing :: CmmNode e x -> Fact x CmmLive -> CmmReplGraph e x
nothing _ _ = return Nothing
compiler/cmm/CmmNode.hs
View file @ caff8eab
......@@ -11,6 +11,7 @@ module CmmNode
( CmmNode(..)
, UpdFrameOffset, Convention(..), ForeignConvention(..), ForeignTarget(..)
, mapExp, mapExpDeep, wrapRecExp, foldExp, foldExpDeep, wrapRecExpf
, mapExpM, mapExpDeepM, wrapRecExpM
)
where
......@@ -22,6 +23,7 @@ import SMRep
import Compiler.Hoopl
import Data.Maybe
import Data.List (tails)
import Prelude hiding (succ)
......@@ -323,6 +325,54 @@ mapExp f (CmmForeignCall tgt fs as succ updfr intrbl) = CmmForeignCall (mapFor
mapExpDeep :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
mapExpDeep f = mapExp $ wrapRecExp f
------------------------------------------------------------------------
-- mapping Expr in CmmNode, but not performing allocation if no changes
mapForeignTargetM :: (CmmExpr -> Maybe CmmExpr) -> ForeignTarget -> Maybe ForeignTarget
mapForeignTargetM f (ForeignTarget e c) = (\x -> ForeignTarget x c) `fmap` f e
mapForeignTargetM _ (PrimTarget _) = Nothing
wrapRecExpM :: (CmmExpr -> Maybe CmmExpr) -> (CmmExpr -> Maybe CmmExpr)
wrapRecExpM f n@(CmmMachOp op es) = maybe (f n) (f . CmmMachOp op) (mapListM (wrapRecExpM f) es)
wrapRecExpM f n@(CmmLoad addr ty) = maybe (f n) (f . flip CmmLoad ty) (wrapRecExpM f addr)
wrapRecExpM f e = f e
mapExpM :: (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x)
mapExpM _ (CmmEntry _) = Nothing
mapExpM _ (CmmComment _) = Nothing
mapExpM f (CmmAssign r e) = CmmAssign r `fmap` f e
mapExpM f (CmmStore addr e) = (\[addr', e'] -> CmmStore addr' e') `fmap` mapListM f [addr, e]
mapExpM _ (CmmBranch _) = Nothing
mapExpM f (CmmCondBranch e ti fi) = (\x -> CmmCondBranch x ti fi) `fmap` f e
mapExpM f (CmmSwitch e tbl) = (\x -> CmmSwitch x tbl) `fmap` f e
mapExpM f (CmmCall tgt mb_id o i s) = (\x -> CmmCall x mb_id o i s) `fmap` f tgt
mapExpM f (CmmUnsafeForeignCall tgt fs as)
= case mapForeignTargetM f tgt of
Just tgt' -> Just (CmmUnsafeForeignCall tgt' fs (mapListJ f as))
Nothing -> (\xs -> CmmUnsafeForeignCall tgt fs xs) `fmap` mapListM f as
mapExpM f (CmmForeignCall tgt fs as succ updfr intrbl)
= case mapForeignTargetM f tgt of
Just tgt' -> Just (CmmForeignCall tgt' fs (mapListJ f as) succ updfr intrbl)
Nothing -> (\xs -> CmmForeignCall tgt fs xs succ updfr intrbl) `fmap` mapListM f as
-- share as much as possible
mapListM :: (a -> Maybe a) -> [a] -> Maybe [a]
mapListM f xs = let (b, r) = mapListT f xs
in if b then Just r else Nothing
mapListJ :: (a -> Maybe a) -> [a] -> [a]
mapListJ f xs = snd (mapListT f xs)
mapListT :: (a -> Maybe a) -> [a] -> (Bool, [a])
mapListT f xs = foldr g (False, []) (zip3 (tails xs) xs (map f xs))
where g (_, y, Nothing) (True, ys) = (True, y:ys)
g (_, _, Just y) (True, ys) = (True, y:ys)
g (ys', _, Nothing) (False, _) = (False, ys')
g (_, _, Just y) (False, ys) = (True, y:ys)
mapExpDeepM :: (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x)
mapExpDeepM f = mapExpM $ wrapRecExpM f
-----------------------------------
-- folding Expr in CmmNode
......
compiler/cmm/CmmOpt.hs
View file @ caff8eab
This diff is collapsed.
compiler/cmm/CmmPipeline.hs
View file @ caff8eab
......@@ -12,6 +12,7 @@ module CmmPipeline (
import CLabel
import Cmm
import CmmDecl
import CmmLive
import CmmBuildInfoTables
import CmmCommonBlockElim
import CmmProcPoint
......@@ -107,10 +108,8 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
dump Opt_D_dump_cmmz_rewrite "Post rewrite assignments" g
----------- Eliminate dead assignments -------------------
-- Remove redundant reloads (and any other redundant asst)
-- in CmmSpillReloads
g <- runOptimization $ removeDeadAssignmentsAndReloads procPoints g
dump Opt_D_dump_cmmz_dead "Post Dead Assignment Elimination" g
g <- runOptimization $ removeDeadAssignments g
dump Opt_D_dump_cmmz_dead "Post remove dead assignments" g
----------- Zero dead stack slots (Debug only) ---------------
-- Debugging: stubbing slots on death can cause crashes early
......
compiler/cmm/CmmRewriteAssignments.hs
View file @ caff8eab
......@@ -17,6 +17,7 @@ module CmmRewriteAssignments
import Cmm
import CmmExpr
import CmmOpt
import OptimizationFuel
import StgCmmUtils
......@@ -40,7 +41,9 @@ rewriteAssignments g = do
-- to actually perform inlining and sinking.
g' <- annotateUsage g
g'' <- liftM fst $ dataflowPassFwd g' [(g_entry g, fact_bot assignmentLattice)] $
analRewFwd assignmentLattice assignmentTransfer assignmentRewrite
analRewFwd assignmentLattice
assignmentTransfer
(assignmentRewrite `thenFwdRw` machOpFoldRewrite)
return (modifyGraph eraseRegUsage g'')
----------------------------------------------------------------
......@@ -604,4 +607,22 @@ assignmentRewrite = mkFRewrite3 first middle last
inlinable (CmmUnsafeForeignCall{}) = False
inlinable _ = True
-- Need to interleave this with inlining, because machop folding results
-- in literals, which we can inline more aggressively, and inlining
-- gives us opportunities for more folding. However, we don't need any
-- facts to do MachOp folding.
machOpFoldRewrite :: FwdRewrite FuelUniqSM (WithRegUsage CmmNode) a
machOpFoldRewrite = mkFRewrite3 first middle last
where first _ _ = return Nothing
middle :: WithRegUsage CmmNode O O -> a -> GenCmmReplGraph (WithRegUsage CmmNode) O O
middle (Plain m) _ = return (fmap (mkMiddle . Plain) (foldNode m))
middle (AssignLocal l e r) _ = return (fmap f (wrapRecExpM foldExp e))
where f e' = mkMiddle (AssignLocal l e' r)
last :: WithRegUsage CmmNode O C -> a -> GenCmmReplGraph (WithRegUsage CmmNode) O C
last (Plain l) _ = return (fmap (mkLast . Plain) (foldNode l))
foldNode :: CmmNode e x -> Maybe (CmmNode e x)
foldNode n = mapExpDeepM foldExp n
foldExp (CmmMachOp op args) = cmmMachOpFoldM op args
foldExp _ = Nothing
-- ToDo: Outputable instance for UsageMap and AssignmentMap
compiler/cmm/CmmSpillReload.hs
View file @ caff8eab
......@@ -9,7 +9,6 @@
module CmmSpillReload
( dualLivenessWithInsertion
, removeDeadAssignmentsAndReloads
)
where
......@@ -56,20 +55,10 @@ be useful in a different context, the memory location is not updated.
data DualLive = DualLive { on_stack :: RegSet, in_regs :: RegSet }
dualUnion :: DualLive -> DualLive -> DualLive
dualUnion (DualLive s r) (DualLive s' r') =
DualLive (s `unionUniqSets` s') (r `unionUniqSets` r')
dualUnionList :: [DualLive] -> DualLive
dualUnionList ls = DualLive ss rs
where ss = unionManyUniqSets $ map on_stack ls
rs = unionManyUniqSets $ map in_regs ls
changeStack, changeRegs :: (RegSet -> RegSet) -> DualLive -> DualLive
changeStack f live = live { on_stack = f (on_stack live) }
changeRegs f live = live { in_regs = f (in_regs live) }
dualLiveLattice :: DataflowLattice DualLive
dualLiveLattice = DataflowLattice "variables live in registers and on stack" empty add
where empty = DualLive emptyRegSet emptyRegSet
......@@ -83,11 +72,7 @@ dualLivenessWithInsertion :: BlockSet -> CmmGraph -> FuelUniqSM CmmGraph
dualLivenessWithInsertion procPoints g =
liftM fst $ dataflowPassBwd g [] $ analRewBwd dualLiveLattice
(dualLiveTransfers (g_entry g) procPoints)
(insertSpillAndReloadRewrites g procPoints)
_dualLiveness :: BlockSet -> CmmGraph -> FuelUniqSM (BlockEnv DualLive)
_dualLiveness procPoints g =
liftM snd $ dataflowPassBwd g [] $ analBwd dualLiveLattice $ dualLiveTransfers (g_entry g) procPoints
(insertSpillsAndReloads g procPoints)
-- Note [Live registers on entry to procpoints]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -121,68 +106,40 @@ dualLiveTransfers entry procPoints = mkBTransfer3 first middle last
-- register slot (and not just a slice).
check (RegSlot (LocalReg _ ty), o, w) x
| o == w && w == widthInBytes (typeWidth ty) = x
check _ _ = panic "middleDualLiveness unsupported: slices"
check _ _ = panic "dualLiveTransfers: slices unsupported"
-- Differences from vanilla liveness analysis
-- Register analysis is identical to liveness analysis from CmmLive.
last :: CmmNode O C -> FactBase DualLive -> DualLive
last l fb = case l of
CmmBranch id -> lkp id
l@(CmmCall {cml_cont=Nothing}) -> changeRegs (gen l . kill l) empty
l@(CmmCall {cml_cont=Just k}) -> call l k
l@(CmmForeignCall {succ=k}) -> call l k
l@(CmmCondBranch _ t f) -> changeRegs (gen l . kill l) $ dualUnion (lkp t) (lkp f)
l@(CmmSwitch _ tbl) -> changeRegs (gen l . kill l) $ dualUnionList $ map lkp (catMaybes tbl)
last l fb = changeRegs (gen_kill l) $ case l of
CmmCall {cml_cont=Nothing} -> empty
CmmCall {cml_cont=Just k} -> keep_stack_only k
CmmForeignCall {succ=k} -> keep_stack_only k
_ -> joinOutFacts dualLiveLattice l fb
where empty = fact_bot dualLiveLattice
lkp id = empty `fromMaybe` lookupFact id fb
call l k = DualLive (on_stack (lkp k)) (gen l emptyRegSet)
lkp k = fromMaybe empty (lookupFact k fb)
keep_stack_only k = DualLive (on_stack (lkp k)) emptyRegSet
gen :: UserOfLocalRegs a => a -> RegSet -> RegSet
gen a live = foldRegsUsed extendRegSet live a
kill :: DefinerOfLocalRegs a => a -> RegSet -> RegSet
kill a live = foldRegsDefd deleteFromRegSet live a
insertSpillAndReloadRewrites :: CmmGraph -> BlockSet -> CmmBwdRewrite DualLive
insertSpillAndReloadRewrites graph procPoints = deepBwdRw3 first middle nothing
insertSpillsAndReloads :: CmmGraph -> BlockSet -> CmmBwdRewrite DualLive
insertSpillsAndReloads graph procPoints = deepBwdRw3 first middle nothing
-- Beware: deepBwdRw with one polymorphic function seems more reasonable here,
-- but GHC miscompiles it, see bug #4044.
where first :: CmmNode C O -> Fact O DualLive -> CmmReplGraph C O
first e@(CmmEntry id) live = return $
if id /= (g_entry graph) && setMember id procPoints then
case map reload (uniqSetToList spill_regs) of
case map reload (uniqSetToList (in_regs live)) of
[] -> Nothing
is -> Just $ mkFirst e <*> mkMiddles is
else Nothing
where
-- If we are splitting procedures, we need the LastForeignCall
-- to spill its results to the stack because they will only
-- be used by a separate procedure (so they can't stay in LocalRegs).
splitting = True
spill_regs = if splitting then in_regs live
else in_regs live `minusRegSet` defs
defs = case mapLookup id firstDefs of
Just defs -> defs
Nothing -> emptyRegSet
-- A LastForeignCall may contain some definitions, which take place
-- on return from the function call. Therefore, we build a map (firstDefs)
-- from BlockId to the set of variables defined on return to the BlockId.
firstDefs = mapFold addLive emptyBlockMap (toBlockMap graph)
addLive :: CmmBlock -> BlockEnv RegSet -> BlockEnv RegSet
addLive b env = case lastNode b of
CmmForeignCall {succ=k, res=defs} -> add k (mkRegSet defs) env
_ -> env
add bid defs env = mapInsert bid defs'' env
where defs'' = case mapLookup bid env of
Just defs' -> timesRegSet defs defs'
Nothing -> defs
-- EZY: There was some dead code for handling the case where
-- we were not splitting procedures. Check Git history if
-- you're interested (circa e26ea0f41).
middle :: CmmNode O O -> Fact O DualLive -> CmmReplGraph O O
-- Don't add spills next to reloads.
middle (CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot (RegSlot reg') _) _)) _ | reg == reg' = return Nothing
middle m@(CmmAssign (CmmLocal reg) _) live = return $
if reg `elemRegSet` on_stack live then -- must spill
my_trace "Spilling" (f4sep [text "spill" <+> ppr reg,
text "after"{-, ppr m-}]) $
Just $ mkMiddles $ [m, spill reg]
else Nothing
-- Spill if register is live on stack.
middle m@(CmmAssign (CmmLocal reg) _) live
| reg `elemRegSet` on_stack live = return (Just (mkMiddles [m, spill reg]))
middle _ _ = return Nothing
nothing _ _ = return Nothing
......@@ -191,25 +148,6 @@ spill, reload :: LocalReg -> CmmNode O O
spill r = CmmStore (regSlot r) (CmmReg $ CmmLocal r)
reload r = CmmAssign (CmmLocal r) (CmmLoad (regSlot r) $ localRegType r)
-- XXX: This should be done with generic liveness analysis and moved to
-- its own module
removeDeadAssignmentsAndReloads :: BlockSet -> CmmGraph -> FuelUniqSM CmmGraph
removeDeadAssignmentsAndReloads procPoints g =
liftM fst $ dataflowPassBwd g [] $ analRewBwd dualLiveLattice
(dualLiveTransfers (g_entry g) procPoints)
rewrites
where rewrites = deepBwdRw3 nothing middle nothing
-- Beware: deepBwdRw with one polymorphic function seems more reasonable here,
-- but GHC panics while compiling, see bug #4045.
middle :: CmmNode O O -> Fact O DualLive -> CmmReplGraph O O
middle (CmmAssign (CmmLocal reg') _) live | not (reg' `elemRegSet` in_regs live) = return $ Just emptyGraph
-- XXX maybe this should be somewhere else...
middle (CmmAssign lhs (CmmReg rhs)) _ | lhs == rhs = return $ Just emptyGraph
middle (CmmStore lhs (CmmLoad rhs _)) _ | lhs == rhs = return $ Just emptyGraph
middle _ _ = return Nothing
nothing _ _ = return Nothing
---------------------
-- prettyprinting
......@@ -226,10 +164,3 @@ instance Outputable DualLive where
else (ppr_regs "live in regs =" regs),
if isEmptyUniqSet stack then PP.empty
else (ppr_regs "live on stack =" stack)]
my_trace :: String -> SDoc -> a -> a
my_trace = if False then pprTrace else \_ _ a -> a
f4sep :: [SDoc] -> SDoc
f4sep [] = fsep []
f4sep (d:ds) = fsep (d : map (nest 4) ds)
compiler/nativeGen/AsmCodeGen.lhs
View file @ caff8eab
......@@ -789,8 +789,13 @@ Here we do:
(i) introduce the appropriate indirections
and position independent refs
(ii) compile a list of imported symbols
(d) Some arch-specific optimizations
Ideas for other things we could do:
(a) and (b) will be moving to the new Hoopl pipeline, however, (c) and
(d) are only needed by the native backend and will continue to live
here.
Ideas for other things we could do (put these in Hoopl please!):
- shortcut jumps-to-jumps
- simple CSE: if an expr is assigned to a temp, then replace later occs of
......@@ -830,6 +835,15 @@ cmmBlockConFold (BasicBlock id stmts) = do
stmts' <- mapM cmmStmtConFold stmts
return $ BasicBlock id stmts'
-- This does three optimizations, but they're very quick to check, so we don't
-- bother turning them off even when the Hoopl code is active. Since
-- this is on the old Cmm representation, we can't reuse the code either:
-- * reg = reg --> nop
-- * if 0 then jump --> nop
-- * if 1 then jump --> jump
-- We might be tempted to skip this step entirely of not opt_PIC, but
-- there is some PowerPC code for the non-PIC case, which would also
-- have to be separated.
cmmStmtConFold :: CmmStmt -> CmmOptM CmmStmt
cmmStmtConFold stmt
= case stmt of
......@@ -876,28 +890,43 @@ cmmStmtConFold stmt
other
-> return other
cmmExprConFold :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
cmmExprConFold referenceKind expr = do
dflags <- getDynFlagsCmmOpt
-- Skip constant folding if new code generator is running
-- (this optimization is done in Hoopl)
let expr' = if dopt Opt_TryNewCodeGen dflags
then expr
else cmmExprCon expr
cmmExprNative referenceKind expr'
cmmExprCon :: CmmExpr -> CmmExpr
cmmExprCon (CmmLoad addr rep) = CmmLoad (cmmExprCon addr) rep
cmmExprCon (CmmMachOp mop args) = cmmMachOpFold mop (map cmmExprCon args)
cmmExprCon other = other
-- handles both PIC and non-PIC cases... a very strange mixture
-- of things to do.
cmmExprNative :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
cmmExprNative referenceKind expr = do
dflags <- getDynFlagsCmmOpt
let arch = platformArch (targetPlatform dflags)
case expr of
CmmLoad addr rep
-> do addr' <- cmmExprConFold DataReference addr
-> do addr' <- cmmExprNative DataReference addr
return $ CmmLoad addr' rep
CmmMachOp mop args
-- For MachOps, we first optimize the children, and then we try
-- our hand at some constant-folding.
-> do args' <- mapM (cmmExprConFold DataReference) args
return $ cmmMachOpFold mop args'
-> do args' <- mapM (cmmExprNative DataReference) args
return $ CmmMachOp mop args'
CmmLit (CmmLabel lbl)
-> do
cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl
cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl
CmmLit (CmmLabelOff lbl off)
-> do
dynRef <- cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl
dynRef <- cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl
-- need to optimize here, since it's late
return $ cmmMachOpFold (MO_Add wordWidth) [
dynRef,
(CmmLit $ CmmInt (fromIntegral off) wordWidth)
......@@ -908,15 +937,15 @@ cmmExprConFold referenceKind expr = do
-- with the corresponding labels:
CmmReg (CmmGlobal EagerBlackholeInfo)
| arch == ArchPPC && not opt_PIC
-> cmmExprConFold referenceKind $
-> cmmExprNative referenceKind $
CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_EAGER_BLACKHOLE_info")))
CmmReg (CmmGlobal GCEnter1)
| arch == ArchPPC && not opt_PIC
-> cmmExprConFold referenceKind $
-> cmmExprNative referenceKind $
CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_enter_1")))
CmmReg (CmmGlobal GCFun)
| arch == ArchPPC && not opt_PIC
-> cmmExprConFold referenceKind $
-> cmmExprNative referenceKind $
CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_fun")))
other
......
compiler/prelude/TysWiredIn.lhs
View file @ caff8eab
......@@ -521,9 +521,9 @@ unitTy = mkTupleTy Boxed []
\end{code}
%************************************************************************
%* *
%* *
\subsection[TysWiredIn-PArr]{The @[::]@ type}
%* *
%* *
%************************************************************************
Special syntax for parallel arrays needs some wired in definitions.
......@@ -546,13 +546,13 @@ parrTyCon = pcNonRecDataTyCon parrTyConName alpha_tyvar [parrDataCon]
parrDataCon :: DataCon
parrDataCon = pcDataCon
parrDataConName
alpha_tyvar -- forall'ed type variables
[intPrimTy, -- 1st argument: Int#
mkTyConApp -- 2nd argument: Array# a
arrayPrimTyCon
alpha_ty]
parrTyCon
parrDataConName
alpha_tyvar -- forall'ed type variables
[intTy, -- 1st argument: Int
mkTyConApp -- 2nd argument: Array# a
arrayPrimTyCon
alpha_ty]
parrTyCon
-- | Check whether a type constructor is the constructor for parallel arrays
isPArrTyCon :: TyCon -> Bool
......@@ -566,27 +566,27 @@ isPArrTyCon tc = tyConName tc == parrTyConName
-- yet another constructor pattern
--
parrFakeCon :: Arity -> DataCon
parrFakeCon i | i > mAX_TUPLE_SIZE = mkPArrFakeCon i -- build one specially
parrFakeCon i | i > mAX_TUPLE_SIZE = mkPArrFakeCon i -- build one specially
parrFakeCon i = parrFakeConArr!i
-- pre-defined set of constructors
--
parrFakeConArr :: Array Int DataCon
parrFakeConArr = array (0, mAX_TUPLE_SIZE) [(i, mkPArrFakeCon i)
| i <- [0..mAX_TUPLE_SIZE]]
| i <- [0..mAX_TUPLE_SIZE]]
-- build a fake parallel array constructor for the given arity
--
mkPArrFakeCon :: Int -> DataCon
mkPArrFakeCon arity = data_con
where
data_con = pcDataCon name [tyvar] tyvarTys parrTyCon
tyvar = head alphaTyVars
tyvarTys = replicate arity $ mkTyVarTy tyvar
data_con = pcDataCon name [tyvar] tyvarTys parrTyCon
tyvar = head alphaTyVars
tyvarTys = replicate arity $ mkTyVarTy tyvar
nameStr = mkFastString ("MkPArr" ++ show arity)
name = mkWiredInName gHC_PARR' (mkDataOccFS nameStr) unique
(ADataCon data_con) UserSyntax
unique = mkPArrDataConUnique arity
name = mkWiredInName gHC_PARR' (mkDataOccFS nameStr) unique
(ADataCon data_con) UserSyntax
unique = mkPArrDataConUnique arity
-- | Checks whether a data constructor is a fake constructor for parallel arrays
isPArrFakeCon :: DataCon -> Bool
......
compiler/vectorise/Vectorise/Builtins/Modules.hs
View file @ caff8eab
......@@ -45,7 +45,7 @@ dph_Modules pkg
, dph_Unboxed = mk (fsLit "Data.Array.Parallel.Lifted.Unboxed")
, dph_Scalar = mk (fsLit "Data.Array.Parallel.Lifted.Scalar")
, dph_Prelude_Tuple = mk (fsLit "Data.Array.Parallel.Prelude.Base.Tuple")
, dph_Prelude_Tuple = mk (fsLit "Data.Array.Parallel.Prelude.Tuple")
}
where mk = mkModule pkg . mkModuleNameFS
......
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