Commit 2e362dde authored by Simon Peyton Jones's avatar Simon Peyton Jones

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
parent aec9e75b
......@@ -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,26 +724,18 @@ 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)
(Lazy, Use _ (UProd ux)) -> Just (mkJointDmds (replicate (length ux) Lazy) ux)
_ -> Nothing
(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
......
{-# 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
......@@ -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, [''])
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