Commit 2304a362 authored by Ian Lynagh's avatar Ian Lynagh

Fix the unregisterised build; fixes #5901

parent a3523855
......@@ -217,6 +217,10 @@ filterRegsUsed p e =
foldRegsUsed (\regs r -> if p r then extendRegSet regs r else regs)
emptyRegSet e
instance UserOfLocalRegs a => UserOfLocalRegs (Maybe a) where
foldRegsUsed f z (Just x) = foldRegsUsed f z x
foldRegsUsed _ z Nothing = z
instance UserOfLocalRegs CmmReg where
foldRegsUsed f z (CmmLocal reg) = f z reg
foldRegsUsed _ z (CmmGlobal _) = z
......
......@@ -134,7 +134,8 @@ lintCmmStmt platform labels = lint
_ <- lintCmmExpr platform r
return ()
lint (CmmCall target _res args _) =
lintTarget platform target >> mapM_ (lintCmmExpr platform . hintlessCmm) args
do lintTarget platform labels target
mapM_ (lintCmmExpr platform . hintlessCmm) args
lint (CmmCondBranch e id) = checkTarget id >> lintCmmExpr platform e >> checkCond platform e
lint (CmmSwitch e branches) = do
mapM_ checkTarget $ catMaybes branches
......@@ -149,9 +150,12 @@ lintCmmStmt platform labels = lint
checkTarget id = if setMember id labels then return ()
else cmmLintErr (text "Branch to nonexistent id" <+> ppr id)
lintTarget :: Platform -> CmmCallTarget -> CmmLint ()
lintTarget platform (CmmCallee e _) = lintCmmExpr platform e >> return ()
lintTarget _ (CmmPrim {}) = return ()
lintTarget :: Platform -> BlockSet -> CmmCallTarget -> CmmLint ()
lintTarget platform _ (CmmCallee e _) = do _ <- lintCmmExpr platform e
return ()
lintTarget _ _ (CmmPrim _ Nothing) = return ()
lintTarget platform labels (CmmPrim _ (Just stmts))
= mapM_ (lintCmmStmt platform labels) stmts
checkCond :: Platform -> CmmExpr -> CmmLint ()
......
......@@ -61,7 +61,8 @@ cmmEliminateDeadBlocks blocks@(BasicBlock base_id _:_) =
stmt m (CmmStore e1 e2) = expr (expr m e1) e2
stmt m (CmmCall c _ as _) = f (actuals m as) c
where f m (CmmCallee e _) = expr m e
f m (CmmPrim _ _) = m
f m (CmmPrim _ Nothing) = m
f m (CmmPrim _ (Just stmts)) = foldl' stmt m stmts
stmt m (CmmBranch b) = b:m
stmt m (CmmCondBranch e b) = b:(expr m e)
stmt m (CmmSwitch e bs) = catMaybes bs ++ expr m e
......@@ -269,7 +270,7 @@ inlineStmt u a (CmmStore e1 e2) = CmmStore (inlineExpr u a e1) (inlineExpr u a e
inlineStmt u a (CmmCall target regs es ret)
= CmmCall (infn target) regs es' ret
where infn (CmmCallee fn cconv) = CmmCallee (inlineExpr u a fn) cconv
infn (CmmPrim p m) = CmmPrim p m
infn (CmmPrim p mStmts) = CmmPrim p (fmap (map (inlineStmt u a)) mStmts)
es' = [ (CmmHinted (inlineExpr u a e) hint) | (CmmHinted e hint) <- es ]
inlineStmt u a (CmmCondBranch e d) = CmmCondBranch (inlineExpr u a e) d
inlineStmt u a (CmmSwitch e d) = CmmSwitch (inlineExpr u a e) d
......
......@@ -222,8 +222,8 @@ instance UserOfLocalRegs CmmStmt where
gen a set = foldRegsUsed f set a
instance UserOfLocalRegs CmmCallTarget where
foldRegsUsed f set (CmmCallee e _) = foldRegsUsed f set e
foldRegsUsed _ set (CmmPrim {}) = set
foldRegsUsed f set (CmmCallee e _) = foldRegsUsed f set e
foldRegsUsed f set (CmmPrim _ mStmts) = foldRegsUsed f set mStmts
instance UserOfSlots CmmCallTarget where
foldSlotsUsed f set (CmmCallee e _) = foldSlotsUsed f set e
......@@ -296,5 +296,5 @@ data CmmCallTarget
-- If we don't know how to implement the
-- mach op, then we can replace it with
-- this list of statements:
(Maybe ([HintedCmmFormal] -> [HintedCmmActual] -> [CmmStmt]))
(Maybe [CmmStmt])
......@@ -237,8 +237,8 @@ pprStmt platform stmt = case stmt of
pprCall platform cast_fn cconv results args <> semi)
-- for a dynamic call, no declaration is necessary.
CmmCall (CmmPrim _ (Just mkStmts)) results args _ret ->
vcat $ map (pprStmt platform) (mkStmts results args)
CmmCall (CmmPrim _ (Just stmts)) _ _ _ ->
vcat $ map (pprStmt platform) stmts
CmmCall (CmmPrim op _) results args _ret ->
pprCall platform ppr_fn CCallConv results args'
......@@ -935,13 +935,19 @@ te_Lit _ = return ()
te_Stmt :: CmmStmt -> TE ()
te_Stmt (CmmAssign r e) = te_Reg r >> te_Expr e
te_Stmt (CmmStore l r) = te_Expr l >> te_Expr r
te_Stmt (CmmCall _ rs es _) = mapM_ (te_temp.hintlessCmm) rs >>
mapM_ (te_Expr.hintlessCmm) es
te_Stmt (CmmCall target rs es _) = do te_Target target
mapM_ (te_temp.hintlessCmm) rs
mapM_ (te_Expr.hintlessCmm) es
te_Stmt (CmmCondBranch e _) = te_Expr e
te_Stmt (CmmSwitch e _) = te_Expr e
te_Stmt (CmmJump e _) = te_Expr e
te_Stmt _ = return ()
te_Target :: CmmCallTarget -> TE ()
te_Target (CmmCallee {}) = return ()
te_Target (CmmPrim _ Nothing) = return ()
te_Target (CmmPrim _ (Just stmts)) = mapM_ te_Stmt stmts
te_Expr :: CmmExpr -> TE ()
te_Expr (CmmLit lit) = te_Lit lit
te_Expr (CmmLoad e _) = te_Expr e
......
......@@ -443,13 +443,11 @@ emitPrimOp [res] op args live
stmtC stmt
emitPrimOp [res_q, res_r] IntQuotRemOp [arg_x, arg_y] _
= let genericImpl [CmmHinted res_q _, CmmHinted res_r _]
[CmmHinted arg_x _, CmmHinted arg_y _]
= let genericImpl
= [CmmAssign (CmmLocal res_q)
(CmmMachOp (MO_S_Quot wordWidth) [arg_x, arg_y]),
CmmAssign (CmmLocal res_r)
(CmmMachOp (MO_S_Rem wordWidth) [arg_x, arg_y])]
genericImpl _ _ = panic "emitPrimOp IntQuotRemOp generic: bad lengths"
stmt = CmmCall (CmmPrim (MO_S_QuotRem wordWidth) (Just genericImpl))
[CmmHinted res_q NoHint,
CmmHinted res_r NoHint]
......@@ -458,13 +456,11 @@ emitPrimOp [res_q, res_r] IntQuotRemOp [arg_x, arg_y] _
CmmMayReturn
in stmtC stmt
emitPrimOp [res_q, res_r] WordQuotRemOp [arg_x, arg_y] _
= let genericImpl [CmmHinted res_q _, CmmHinted res_r _]
[CmmHinted arg_x _, CmmHinted arg_y _]
= let genericImpl
= [CmmAssign (CmmLocal res_q)
(CmmMachOp (MO_U_Quot wordWidth) [arg_x, arg_y]),
CmmAssign (CmmLocal res_r)
(CmmMachOp (MO_U_Rem wordWidth) [arg_x, arg_y])]
genericImpl _ _ = panic "emitPrimOp WordQuotRemOp generic: bad lengths"
stmt = CmmCall (CmmPrim (MO_U_QuotRem wordWidth) (Just genericImpl))
[CmmHinted res_q NoHint,
CmmHinted res_r NoHint]
......@@ -477,8 +473,7 @@ emitPrimOp [res_h, res_l] WordAdd2Op [arg_x, arg_y] _
r2 <- newLocalReg (cmmExprType arg_x)
-- This generic implementation is very simple and slow. We might
-- well be able to do better, but for now this at least works.
let genericImpl [CmmHinted res_h _, CmmHinted res_l _]
[CmmHinted arg_x _, CmmHinted arg_y _]
let genericImpl
= [CmmAssign (CmmLocal r1)
(add (bottomHalf arg_x) (bottomHalf arg_y)),
CmmAssign (CmmLocal r2)
......@@ -497,7 +492,6 @@ emitPrimOp [res_h, res_l] WordAdd2Op [arg_x, arg_y] _
hww = CmmLit (CmmInt (fromIntegral (widthInBits halfWordWidth))
wordWidth)
hwm = CmmLit (CmmInt halfWordMask wordWidth)
genericImpl _ _ = panic "emitPrimOp WordAdd2Op generic: bad lengths"
stmt = CmmCall (CmmPrim (MO_Add2 wordWidth) (Just genericImpl))
[CmmHinted res_h NoHint,
CmmHinted res_l NoHint]
......@@ -513,8 +507,7 @@ emitPrimOp [res_h, res_l] WordMul2Op [arg_x, arg_y] _
r <- liftM CmmLocal $ newLocalReg t
-- This generic implementation is very simple and slow. We might
-- well be able to do better, but for now this at least works.
let genericImpl [CmmHinted res_h _, CmmHinted res_l _]
[CmmHinted arg_x _, CmmHinted arg_y _]
let genericImpl
= [CmmAssign xlyl
(mul (bottomHalf arg_x) (bottomHalf arg_y)),
CmmAssign xlyh
......@@ -543,7 +536,6 @@ emitPrimOp [res_h, res_l] WordMul2Op [arg_x, arg_y] _
hww = CmmLit (CmmInt (fromIntegral (widthInBits halfWordWidth))
wordWidth)
hwm = CmmLit (CmmInt halfWordMask wordWidth)
genericImpl _ _ = panic "emitPrimOp WordMul2Op generic: bad lengths"
stmt = CmmCall (CmmPrim (MO_U_Mul2 wordWidth) (Just genericImpl))
[CmmHinted res_h NoHint,
CmmHinted res_l NoHint]
......
......@@ -1011,7 +1011,8 @@ fixStgRegStmt stmt
CmmCall target regs args returns ->
let target' = case target of
CmmCallee e conv -> CmmCallee (fixStgRegExpr e) conv
other -> other
CmmPrim op mStmts ->
CmmPrim op (fmap (map fixStgRegStmt) mStmts)
args' = map (\(CmmHinted arg hint) ->
(CmmHinted (fixStgRegExpr arg) hint)) args
in CmmCall target' regs args' returns
......
......@@ -202,9 +202,10 @@ genCall env t@(CmmPrim (MO_PopCnt w) _) [CmmHinted dst _] args _ = do
-- Handle memcpy function specifically since llvm's intrinsic version takes
-- some extra parameters.
genCall env t@(CmmPrim op _) [] args CmmMayReturn | op == MO_Memcpy ||
op == MO_Memset ||
op == MO_Memmove = do
genCall env t@(CmmPrim op _) [] args CmmMayReturn
| op == MO_Memcpy ||
op == MO_Memset ||
op == MO_Memmove = do
let (isVolTy, isVolVal) = if getLlvmVer env >= 28
then ([i1], [mkIntLit i1 0]) else ([], [])
argTy | op == MO_Memset = [i8Ptr, i8, llvmWord, i32] ++ isVolTy
......@@ -222,8 +223,8 @@ genCall env t@(CmmPrim op _) [] args CmmMayReturn | op == MO_Memcpy ||
`appOL` trashStmts `snocOL` call
return (env2, stmts, top1 ++ top2)
genCall env (CmmPrim _ (Just mkStmts)) results args _
= stmtsToInstrs env (mkStmts results args) (nilOL, [])
genCall env (CmmPrim _ (Just stmts)) _ _ _
= stmtsToInstrs env stmts (nilOL, [])
-- Handle all other foreign calls and prim ops.
genCall env target res args ret = do
......
......@@ -880,7 +880,11 @@ cmmStmtConFold stmt
CmmCallee e conv -> do
e' <- cmmExprConFold CallReference e
return $ CmmCallee e' conv
other -> return other
op@(CmmPrim _ Nothing) ->
return op
CmmPrim op (Just stmts) ->
do stmts' <- mapM cmmStmtConFold stmts
return $ CmmPrim op (Just stmts')
args' <- mapM (\(CmmHinted arg hint) -> do
arg' <- cmmExprConFold DataReference arg
return (CmmHinted arg' hint)) args
......
......@@ -901,8 +901,8 @@ genCCall'
genCCall' _ (CmmPrim MO_WriteBarrier _) _ _
= return $ unitOL LWSYNC
genCCall' _ (CmmPrim _ (Just mkStmts)) results args
= stmtsToInstrs (mkStmts results args)
genCCall' _ (CmmPrim _ (Just stmts)) _ _
= stmtsToInstrs stmts
genCCall' gcp target dest_regs argsAndHints
= ASSERT (not $ any (`elem` [II16]) $ map cmmTypeSize argReps)
......@@ -946,7 +946,7 @@ genCCall' gcp target dest_regs argsAndHints
GCPLinux -> roundTo 16 finalStack
-- need to remove alignment information
argsAndHints' | (CmmPrim mop _) <- target,
argsAndHints' | CmmPrim mop _ <- target,
(mop == MO_Memcpy ||
mop == MO_Memset ||
mop == MO_Memmove)
......
......@@ -383,13 +383,13 @@ genCCall
genCCall (CmmPrim (MO_WriteBarrier) _) _ _
= do return nilOL
genCCall (CmmPrim _ (Just mkStmts)) results args
= stmtsToInstrs (mkStmts results args)
genCCall (CmmPrim _ (Just stmts)) _ _
= stmtsToInstrs stmts
genCCall target dest_regs argsAndHints
= do
-- need to remove alignment information
let argsAndHints' | (CmmPrim mop _) <- target,
let argsAndHints' | CmmPrim mop _ <- target,
(mop == MO_Memcpy ||
mop == MO_Memset ||
mop == MO_Memmove)
......
......@@ -1707,8 +1707,8 @@ genCCall32 target dest_regs args =
return code
_ -> panic "genCCall32: Wrong number of arguments/results for add2"
(CmmPrim _ (Just mkStmts), results) ->
stmtsToInstrs (mkStmts results args)
(CmmPrim _ (Just stmts), _) ->
stmtsToInstrs stmts
_ -> genCCall32' target dest_regs args
......@@ -1927,8 +1927,8 @@ genCCall64 target dest_regs args =
return code
_ -> panic "genCCall64: Wrong number of arguments/results for add2"
(CmmPrim _ (Just mkStmts), results) ->
stmtsToInstrs (mkStmts results args)
(CmmPrim _ (Just stmts), _) ->
stmtsToInstrs stmts
_ -> genCCall64' target dest_regs args
......
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