Fix the unregisterised build; fixes #5901

12 files changed, 55 insertions, 42 deletions

diff --git a/compiler/cmm/CmmExpr.hs b/compiler/cmm/CmmExpr.hs
index 885639b874..6eb91e89ba 100644
--- a/compiler/cmm/CmmExpr.hs
+++ b/compiler/cmm/CmmExpr.hs
@@ -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
diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs
index bed3b18b8e..98e6eb286d 100644
--- a/compiler/cmm/CmmLint.hs
+++ b/compiler/cmm/CmmLint.hs
@@ -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 ()
diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs
index 8066c60157..e4ad450069 100644
--- a/compiler/cmm/CmmOpt.hs
+++ b/compiler/cmm/CmmOpt.hs
@@ -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
diff --git a/compiler/cmm/OldCmm.hs b/compiler/cmm/OldCmm.hs
index 97fdd4aed5..fc4706c8c4 100644
--- a/compiler/cmm/OldCmm.hs
+++ b/compiler/cmm/OldCmm.hs
@@ -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])
 
diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs
index 3e28484c94..9da00590c2 100644
--- a/compiler/cmm/PprC.hs
+++ b/compiler/cmm/PprC.hs
@@ -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
diff --git a/compiler/codeGen/CgPrimOp.hs b/compiler/codeGen/CgPrimOp.hs
index 2fad514096..3f1187f6be 100644
--- a/compiler/codeGen/CgPrimOp.hs
+++ b/compiler/codeGen/CgPrimOp.hs
@@ -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]
diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs
index 2bd35c8796..f971a0500a 100644
--- a/compiler/codeGen/CgUtils.hs
+++ b/compiler/codeGen/CgUtils.hs
@@ -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
diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
index cfd0ac22b6..70fa51aaa2 100644
--- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
@@ -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
diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs
index 88fcde262b..1ad1242b31 100644
--- a/compiler/nativeGen/AsmCodeGen.lhs
+++ b/compiler/nativeGen/AsmCodeGen.lhs
@@ -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
diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs
index 64f8e17e4e..a30834daf6 100644
--- a/compiler/nativeGen/PPC/CodeGen.hs
+++ b/compiler/nativeGen/PPC/CodeGen.hs
@@ -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)
diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs
index 66461551a9..85fd901c42 100644
--- a/compiler/nativeGen/SPARC/CodeGen.hs
+++ b/compiler/nativeGen/SPARC/CodeGen.hs
@@ -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)
diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs
index 89229226af..f134255578 100644
--- a/compiler/nativeGen/X86/CodeGen.hs
+++ b/compiler/nativeGen/X86/CodeGen.hs
@@ -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