Skip to content

GitLab

GHC
GHC
Commit 00d351b7 authored by simonpj's avatar simonpj
Browse files
Options

[project @ 1999-09-17 09:11:20 by simonpj] 

Remove SST.lhs
parent ae7f92a5
Hide whitespace changes
Inline Side-by-side
Showing with 20 additions and 259 deletions
ghc/compiler/Makefile
View file @ 00d351b7
# -----------------------------------------------------------------------------
# $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"
......
ghc/compiler/basicTypes/Const.lhs
View file @ 00d351b7
......@@ -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
......
ghc/compiler/basicTypes/Id.lhs
View file @ 00d351b7
......@@ -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}
ghc/compiler/basicTypes/IdInfo.lhs
View file @ 00d351b7
......@@ -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}
......
ghc/compiler/utils/SST.lhs deleted 100644 → 0
View file @ ae7f92a5
\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}
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