Make splitStrProdDmd (and similarly Use) more robust

The issue here is avoiding a GHC crash when a program uses
unsafeCoerce is a dangerous (or even outright-wrong) way.

See Trac #9208

compiler/basicTypes/Demand.lhs

@@ -42,7 +42,7 @@ module Demand (
         deferAfterIO,
         postProcessUnsat, postProcessDmdTypeM,
 
-        splitProdDmd, splitProdDmd_maybe, peelCallDmd, mkCallDmd,
+        splitProdDmd_maybe, peelCallDmd, mkCallDmd,
         dmdTransformSig, dmdTransformDataConSig, dmdTransformDictSelSig,
         argOneShots, argsOneShots,
         trimToType, TypeShape(..),
@@ -201,11 +201,13 @@ seqMaybeStr Lazy    = ()
 seqMaybeStr (Str s) = seqStrDmd s
 
 -- Splitting polymorphic demands
-splitStrProdDmd :: Int -> StrDmd -> [MaybeStr]
-splitStrProdDmd n HyperStr     = replicate n strBot
-splitStrProdDmd n HeadStr      = replicate n strTop
-splitStrProdDmd n (SProd ds)   = ASSERT( ds `lengthIs` n) ds
-splitStrProdDmd _ d@(SCall {}) = pprPanic "attempt to prod-split strictness call demand" (ppr d)
+splitStrProdDmd :: Int -> StrDmd -> Maybe [MaybeStr]
+splitStrProdDmd n HyperStr   = Just (replicate n strBot)
+splitStrProdDmd n HeadStr    = Just (replicate n strTop)
+splitStrProdDmd n (SProd ds) = ASSERT( ds `lengthIs` n) Just ds
+splitStrProdDmd _ (SCall {}) = Nothing
+      -- This can happen when the programmer uses unsafeCoerce,
+      -- and we don't then want to crash the compiler (Trac #9208)
 \end{code}
 
 %************************************************************************
@@ -442,13 +444,15 @@ seqMaybeUsed (Use c u)  = c `seq` seqUseDmd u
 seqMaybeUsed _          = ()
 
 -- Splitting polymorphic Maybe-Used demands
-splitUseProdDmd :: Int -> UseDmd -> [MaybeUsed]
-splitUseProdDmd n Used          = replicate n useTop
-splitUseProdDmd n UHead         = replicate n Abs
-splitUseProdDmd n (UProd ds)    = ASSERT2( ds `lengthIs` n, text "splitUseProdDmd" $$ ppr n $$ ppr ds ) ds
-splitUseProdDmd _ d@(UCall _ _) = pprPanic "attempt to prod-split usage call demand" (ppr d)
+splitUseProdDmd :: Int -> UseDmd -> Maybe [MaybeUsed]
+splitUseProdDmd n Used        = Just (replicate n useTop)
+splitUseProdDmd n UHead       = Just (replicate n Abs)
+splitUseProdDmd n (UProd ds)  = ASSERT2( ds `lengthIs` n, text "splitUseProdDmd" $$ ppr n $$ ppr ds ) 
+                                Just ds
+splitUseProdDmd _ (UCall _ _) = Nothing
+      -- This can happen when the programmer uses unsafeCoerce,
+      -- and we don't then want to crash the compiler (Trac #9208)
 \end{code}
-  
 %************************************************************************
 %*                                                                      *
 \subsection{Joint domain for Strictness and Absence}
@@ -720,24 +724,16 @@ can be expanded to saturate a callee's arity.
 
 
 \begin{code}
-splitProdDmd :: Arity -> JointDmd -> [JointDmd]
-splitProdDmd n (JD {strd = s, absd = u})
-  = mkJointDmds (split_str s) (split_abs u)
-  where
-    split_str Lazy    = replicate n Lazy
-    split_str (Str s) = splitStrProdDmd n s
-
-    split_abs Abs       = replicate n Abs
-    split_abs (Use _ u) = splitUseProdDmd n u
-
 splitProdDmd_maybe :: JointDmd -> Maybe [JointDmd]
 -- Split a product into its components, iff there is any
 -- useful information to be extracted thereby
 -- The demand is not necessarily strict!
 splitProdDmd_maybe (JD {strd = s, absd = u})
   = case (s,u) of
-      (Str (SProd sx), Use _ u)          -> Just (mkJointDmds sx (splitUseProdDmd (length sx) u))
-      (Str s,          Use _ (UProd ux)) -> Just (mkJointDmds (splitStrProdDmd (length ux) s) ux)
+      (Str (SProd sx), Use _ u)          | Just ux <- splitUseProdDmd (length sx) u
+                                         -> Just (mkJointDmds sx ux)
+      (Str s,          Use _ (UProd ux)) | Just sx <- splitStrProdDmd (length ux) s
+                                         -> Just (mkJointDmds sx ux)
       (Lazy,           Use _ (UProd ux)) -> Just (mkJointDmds (replicate (length ux) Lazy) ux)
       _ -> Nothing
 \end{code}
@@ -1522,12 +1518,12 @@ dmdTransformDataConSig arity (StrictSig (DmdType _ _ con_res))
   | otherwise   -- Not saturated
   = nopDmdType
   where
-    go_str 0 dmd        = Just (splitStrProdDmd arity dmd)
+    go_str 0 dmd        = splitStrProdDmd arity dmd
     go_str n (SCall s') = go_str (n-1) s'
     go_str n HyperStr   = go_str (n-1) HyperStr
     go_str _ _          = Nothing
 
-    go_abs 0 dmd            = Just (splitUseProdDmd arity dmd)
+    go_abs 0 dmd            = splitUseProdDmd arity dmd
     go_abs n (UCall One u') = go_abs (n-1) u'
     go_abs _ _              = Nothing
 

testsuite/tests/stranal/should_compile/T9208.hs

+{-# LANGUAGE CPP, LambdaCase, BangPatterns, MagicHash, TupleSections, ScopedTypeVariables #-}
+{-# OPTIONS_GHC -w #-}  -- Suppress warnings for unimplemented methods
+
+{- | Evaluate Template Haskell splices on node.js,
+     using pipes to communicate with GHCJS
+ -}
+
+-- module GHCJS.Prim.TH.Eval
+module Eval (
+         runTHServer
+       ) where
+
+import           Control.Applicative
+import           Control.Monad
+
+import           Data.Binary
+import           Data.Binary.Get
+import           Data.ByteString          (ByteString)
+import qualified Data.ByteString          as B
+import qualified Data.ByteString.Lazy     as BL
+
+import           GHC.Prim
+
+import qualified Language.Haskell.TH        as TH
+import qualified Language.Haskell.TH.Syntax as TH
+
+import           Unsafe.Coerce
+
+data THResultType = THExp | THPat | THType | THDec
+
+data Message
+  -- | GHCJS compiler to node.js requests
+  = RunTH THResultType ByteString TH.Loc 
+  -- | node.js to GHCJS compiler responses
+  | RunTH' THResultType ByteString [TH.Dec] -- ^ serialized AST and additional toplevel declarations
+
+instance Binary THResultType where
+  put _ = return ()
+  get   = return undefined
+
+instance Binary Message where
+  put _ = return ()
+  get   = return undefined
+
+data QState = QState
+
+data GHCJSQ a = GHCJSQ { runGHCJSQ :: QState -> IO (a, QState) }
+
+instance Functor GHCJSQ where
+  fmap f (GHCJSQ s) = GHCJSQ $ fmap (\(x,s') -> (f x,s')) . s
+
+instance Applicative GHCJSQ where
+  f <*> a = GHCJSQ $ \s ->
+    do (f',s')   <- runGHCJSQ f s
+       (a', s'') <- runGHCJSQ a s'
+       return (f' a', s'')
+  pure x = GHCJSQ (\s -> return (x,s))
+
+instance Monad GHCJSQ where
+  (>>=) m f = GHCJSQ $ \s ->
+    do (m', s')  <- runGHCJSQ m s
+       (a,  s'') <- runGHCJSQ (f m') s'
+       return (a, s'')
+  return    = pure
+
+instance TH.Quasi GHCJSQ where qRunIO m = GHCJSQ $ \s -> fmap (,s) m
+
+-- | the Template Haskell server
+runTHServer :: IO ()
+runTHServer = void $ runGHCJSQ server QState
+  where
+    server = TH.qRunIO awaitMessage >>= \case
+      RunTH t code loc -> do
+        a <- TH.qRunIO $ loadTHData code
+        runTH t a loc
+      _ -> TH.qRunIO (putStrLn "warning: ignoring unexpected message type")
+
+runTH :: THResultType -> Any -> TH.Loc -> GHCJSQ ()
+runTH rt obj loc = do
+  res <- case rt of
+           THExp  -> runTHCode (unsafeCoerce obj :: TH.Q TH.Exp)
+           THPat  -> runTHCode (unsafeCoerce obj :: TH.Q TH.Pat) 
+           THType -> runTHCode (unsafeCoerce obj :: TH.Q TH.Type)
+           THDec  -> runTHCode (unsafeCoerce obj :: TH.Q [TH.Dec])
+  TH.qRunIO (sendResult $ RunTH' rt res [])
+
+runTHCode :: {- Binary a => -} TH.Q a -> GHCJSQ ByteString
+runTHCode c = TH.runQ c >> return B.empty
+
+loadTHData :: ByteString -> IO Any
+loadTHData bs = return (unsafeCoerce ()) 
+
+awaitMessage :: IO Message
+awaitMessage = fmap (runGet get) (return BL.empty)
+
+-- | send result back
+sendResult :: Message -> IO ()
+sendResult msg = return ()
\ No newline at end of file

testsuite/tests/stranal/should_compile/all.T

@@ -19,4 +19,4 @@ test('T1988', normal, compile, [''])
 test('T8467', normal, compile, [''])
 test('T8037', normal, compile, [''])
 test('T8743', [ extra_clean(['T8743.o-boot', 'T8743.hi-boot']) ], multimod_compile, ['T8743', '-v0'])
-
+test('T9208', normal, compile, [''])