From 00d351b7fc0a66368f9d6b8a1bbe15d32e204f01 Mon Sep 17 00:00:00 2001 From: simonpj Date: Fri, 17 Sep 1999 09:11:39 +0000 Subject: [PATCH] [project @ 1999-09-17 09:11:20 by simonpj] Remove SST.lhs --- ghc/compiler/Makefile | 6 +- ghc/compiler/basicTypes/Const.lhs | 6 +- ghc/compiler/basicTypes/Id.lhs | 11 +- ghc/compiler/basicTypes/IdInfo.lhs | 5 +- ghc/compiler/utils/SST.lhs | 251 ------------------------------------ 5 files changed, 20 insertions(+), 259 deletions(-) delete mode 100644 ghc/compiler/utils/SST.lhs diff --git a/ghc/compiler/Makefile b/ghc/compiler/Makefile index 087a3e4..e94c91d 100644 --- a/ghc/compiler/Makefile +++ b/ghc/compiler/Makefile @@ -1,5 +1,5 @@ # ----------------------------------------------------------------------------- -# $Id: Makefile,v 1.64 1999/07/14 20:29:34 panne Exp $ +# $Id: Makefile,v 1.65 1999/09/17 09:11:20 simonpj Exp $ TOP = .. include $(TOP)/mk/boilerplate.mk @@ -150,10 +150,10 @@ prelude/PrimOp_HC_OPTS = -H12m -K3m parser/Lex_HC_OPTS = -K2m -H16m -fvia-C # -dcore-lint is *temporary* to work around ghc space leak. -rename/ParseIface_HC_OPTS += -Onot -H45m -K2m -dcore-lint -fno-warn-incomplete-patterns -dcore-lint +rename/ParseIface_HC_OPTS += -Onot -H45m -K2m -dcore-lint -fno-warn-incomplete-patterns rename/ParseIface_HAPPY_OPTS += -g -parser/Parser_HC_OPTS += -Onot -H80m -K2m -dcore-lint -fno-warn-incomplete-patterns -dcore-lint +parser/Parser_HC_OPTS += -Onot -H45m -K2m -dcore-lint -fno-warn-incomplete-patterns parser/Parser_HAPPY_OPTS += -g ifeq "$(TARGETPLATFORM)" "hppa1.1-hp-hpux9" diff --git a/ghc/compiler/basicTypes/Const.lhs b/ghc/compiler/basicTypes/Const.lhs index 0e627c4..22fa7f8 100644 --- a/ghc/compiler/basicTypes/Const.lhs +++ b/ghc/compiler/basicTypes/Const.lhs @@ -128,9 +128,11 @@ conIsTrivial (Literal lit) = not (isNoRepLit lit) conIsTrivial (PrimOp _) = False conIsTrivial con = True --- conIsCheap is true for constants whose applications we are willing +-- conIsCheap is true for constants whose *work* we are willing -- to duplicate in exchange for some modest gain. cf CoreUtils.exprIsCheap -conIsCheap (Literal lit) = not (isNoRepLit lit) +conIsCheap (Literal lit) = True -- Even no-rep lits are cheap; we don't end + -- up duplicating their work if we push them inside + -- a lambda, because we float them to the top in the end conIsCheap (DataCon con) = True conIsCheap (PrimOp op) = primOpIsCheap op diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index 25ff7b5..11aa08d 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -36,7 +36,7 @@ module Id ( isExportedId, isUserExportedId, -- One shot lambda stuff - isOneShotLambda, setOneShotLambda, + isOneShotLambda, setOneShotLambda, clearOneShotLambda, -- IdInfo stuff setIdUnfolding, @@ -397,4 +397,13 @@ isOneShotLambda id = case lbvarInfo (idInfo id) of setOneShotLambda :: Id -> Id setOneShotLambda id = modifyIdInfo (`setLBVarInfo` IsOneShotLambda) id + +clearOneShotLambda :: Id -> Id +clearOneShotLambda id + | isOneShotLambda id = modifyIdInfo (`setLBVarInfo` NoLBVarInfo) id + | otherwise = id + +-- But watch out: this may change the type of something else +-- f = \x -> e +-- If we change the one-shot-ness of x, f's type changes \end{code} diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs index ac1ef78..61b3a0e 100644 --- a/ghc/compiler/basicTypes/IdInfo.lhs +++ b/ghc/compiler/basicTypes/IdInfo.lhs @@ -350,7 +350,8 @@ instance Outputable InlinePragInfo where ppr IAmALoopBreaker = ptext SLIT("__Ux") ppr IAmDead = ptext SLIT("__Ud") ppr (ICanSafelyBeINLINEd InsideLam _) = ptext SLIT("__Ul") - ppr (ICanSafelyBeINLINEd _ _) = ptext SLIT("__Us") + ppr (ICanSafelyBeINLINEd NotInsideLam True) = ptext SLIT("__Us") + ppr (ICanSafelyBeINLINEd NotInsideLam False) = ptext SLIT("__Us*") instance Show InlinePragInfo where showsPrec p prag = showsPrecSDoc p (ppr prag) @@ -463,7 +464,7 @@ ppWorkerInfo (Just wk_id) = ptext SLIT("__P") <+> ppr wk_id noWorkerInfo = Nothing -workerExists :: Maybe Id -> Bool +workerExists :: WorkerInfo -> Bool workerExists = isJust \end{code} diff --git a/ghc/compiler/utils/SST.lhs b/ghc/compiler/utils/SST.lhs deleted file mode 100644 index 1887873..0000000 --- a/ghc/compiler/utils/SST.lhs +++ /dev/null @@ -1,251 +0,0 @@ -\section{SST: the strict state transformer monad} -%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -\begin{code} -module SST( - SST, SST_R, FSST, FSST_R, - - runSST, sstToST, stToSST, ioToSST, - thenSST, thenSST_, returnSST, fixSST, - thenFSST, thenFSST_, returnFSST, failFSST, - recoverFSST, recoverSST, fixFSST, - unsafeInterleaveSST, - - newMutVarSST, readMutVarSST, writeMutVarSST, - SSTRef - ) where - -#include "HsVersions.h" - -import GlaExts -import ST - -#if __GLASGOW_HASKELL__ < 301 -import STBase ( ST(..), STret(..), StateAndPtr#(..) ) -import ArrBase ( StateAndMutableArray#(..) ) -import IOBase ( IO(..), IOResult(..) ) -#elif __GLASGOW_HASKELL__ < 400 -import PrelST ( ST(..), STret(..), StateAndPtr#(..) ) -import PrelArr ( StateAndMutableArray#(..) ) -import PrelIOBase ( IO(..), IOResult(..) ) -#else -import PrelST ( ST(..), STret(..) ) -import PrelArr ( MutableVar(..) ) -import PrelIOBase ( IO(..) ) -#endif - -\end{code} - -@SST@ is very like the standard @ST@ monad, but it comes with its -friend @FSST@. Because we want the monadic bind operator to work -for mixtures of @SST@ and @FSST@, we can't use @ST@ at all. - -For simplicity we don't even dress them up in newtypes. - -%************************************************************************ -%* * -\subsection{The data types} -%* * -%************************************************************************ - -\begin{code} -type SST s r = State# s -> SST_R s r -type FSST s r err = State# s -> FSST_R s r err - -data SST_R s r = SST_R r (State# s) - -data FSST_R s r err - = FSST_R_OK r (State# s) - | FSST_R_Fail err (State# s) -\end{code} - -Converting to/from ST - -\begin{code} -sstToST :: SST s r -> ST s r -stToSST :: ST s r -> SST s r - - -#if __GLASGOW_HASKELL__ < 400 -stToSST (ST st) = \ s -> case st s of STret s' r -> SST_R r s' -sstToST sst = ST (\ s -> case sst s of SST_R r s' -> STret s' r) -#else -stToSST (ST st) = \ s -> case st s of (# s', r #) -> SST_R r s' -sstToST sst = ST (\ s -> case sst s of SST_R r s' -> (# s', r #)) -#endif -\end{code} - -...and IO - -\begin{code} -ioToSST :: IO a -> SST RealWorld (Either IOError a) - -#if __GLASGOW_HASKELL__ < 400 -ioToSST (IO io) - = \s -> case io s of - IOok s' r -> SST_R (Right r) s' - IOfail s' err -> SST_R (Left err) s' -#else - --- We should probably be using ST and exceptions instead of SST here, now --- that GHC has exceptions and ST is strict. - -ioToSST io - = \s -> case catch (io >>= return . Right) (return . Left) of { IO m -> - case m s of { - (# s', r #) -> SST_R r s' - } } -#endif - -\end{code} - -%************************************************************************ -%* * -\subsection{The @SST@ operations} -%* * -%************************************************************************ - -\begin{code} --- Type of runSST should be builtin ... --- runSST :: forall r. (forall s. SST s r) -> r - -runSST :: SST RealWorld r -> r -runSST m = case m realWorld# of SST_R r s -> r - -unsafeInterleaveSST :: SST s r -> SST s r -unsafeInterleaveSST m s = SST_R r s -- Duplicates the state! - where - SST_R r _ = m s - -returnSST :: r -> SST s r -fixSST :: (r -> SST s r) -> SST s r -{-# INLINE returnSST #-} -{-# INLINE thenSST #-} -{-# INLINE thenSST_ #-} - -returnSST r s = SST_R r s - -fixSST m s = result - where - result = m loop s - SST_R loop _ = result -\end{code} - -OK, here comes the clever bind operator. - -\begin{code} -thenSST :: SST s r -> (r -> State# s -> b) -> State# s -> b -thenSST_ :: SST s r -> (State# s -> b) -> State# s -> b --- Hence: --- thenSST :: SST s r -> (r -> SST s r') -> SST s r' --- and thenSST :: SST s r -> (r -> FSST s r' err) -> FSST s r' err - --- Hence: --- thenSST_ :: SST s r -> SST s r' -> SST s r' --- and thenSST_ :: SST s r -> FSST s r' err -> FSST s r' err - -thenSST m k s = case m s of { SST_R r s' -> k r s' } - -thenSST_ m k s = case m s of { SST_R r s' -> k s' } -\end{code} - - -%************************************************************************ -%* * -\subsection{FSST: the failable strict state transformer monad} -%* * -%************************************************************************ - -\begin{code} -failFSST :: err -> FSST s r err -fixFSST :: (r -> FSST s r err) -> FSST s r err -recoverFSST :: (err -> FSST s r err) -> FSST s r err -> FSST s r err -recoverSST :: (err -> SST s r) -> FSST s r err -> SST s r -returnFSST :: r -> FSST s r err -thenFSST :: FSST s r err -> (r -> FSST s r' err) -> FSST s r' err -thenFSST_ :: FSST s r err -> FSST s r' err -> FSST s r' err -{-# INLINE failFSST #-} -{-# INLINE returnFSST #-} -{-# INLINE thenFSST #-} -{-# INLINE thenFSST_ #-} - -thenFSST m k s = case m s of - FSST_R_OK r s' -> k r s' - FSST_R_Fail err s' -> FSST_R_Fail err s' - -thenFSST_ m k s = case m s of - FSST_R_OK r s' -> k s' - FSST_R_Fail err s' -> FSST_R_Fail err s' - -returnFSST r s = FSST_R_OK r s - -failFSST err s = FSST_R_Fail err s - -recoverFSST recovery_fn m s - = case m s of - FSST_R_OK r s' -> FSST_R_OK r s' - FSST_R_Fail err s' -> recovery_fn err s' - -recoverSST recovery_fn m s - = case m s of - FSST_R_OK r s' -> SST_R r s' - FSST_R_Fail err s' -> recovery_fn err s' - -fixFSST m s = result - where - result = m loop s - FSST_R_OK loop _ = result -\end{code} - -%************************************************************************ -%* * -\subsection{Mutables} -%* * -%************************************************************************ - -Here we implement mutable variables. - -\begin{code} -#if __GLASGOW_HASKELL__ < 400 -type SSTRef s a = MutableArray s Int a -#else -type SSTRef s a = MutableVar s a -#endif - -newMutVarSST :: a -> SST s (SSTRef s a) -readMutVarSST :: SSTRef s a -> SST s a -writeMutVarSST :: SSTRef s a -> a -> SST s () - -#if __GLASGOW_HASKELL__ < 400 - -newMutVarSST init s# - = case (newArray# 1# init s#) of { StateAndMutableArray# s2# arr# -> - SST_R (MutableArray vAR_IXS arr#) s2# } - where - vAR_IXS = error "Shouldn't access `bounds' of a MutableVar\n" - -readMutVarSST (MutableArray _ var#) s# - = case readArray# var# 0# s# of { StateAndPtr# s2# r -> - SST_R r s2# } - -writeMutVarSST (MutableArray _ var#) val s# - = case writeArray# var# 0# val s# of { s2# -> - SST_R () s2# } - -#else - -newMutVarSST init s# - = case (newMutVar# init s#) of { (# s2#, var# #) -> - SST_R (MutableVar var#) s2# } - -readMutVarSST (MutableVar var#) s# - = case readMutVar# var# s# of { (# s2#, r #) -> - SST_R r s2# } - -writeMutVarSST (MutableVar var#) val s# - = case writeMutVar# var# val s# of { s2# -> - SST_R () s2# } - -#endif -\end{code} - -- 1.7.10.4