Skip to content

GitLab

GHC
GHC
Commit 612e5736 authored by Austin Seipp's avatar Austin Seipp
Browse files
Options

compiler: de-lhs stgSyn/ 

Signed-off-by: default avatarAustin Seipp <austin@well-typed.com>
parent 6ecd27ea
Hide whitespace changes
Inline Side-by-side
Showing with 144 additions and 163 deletions
compiler/stgSyn/CoreToStg.lhs → compiler/stgSyn/CoreToStg.hs
View file @ 612e5736
\begin{code}
{-# LANGUAGE CPP #-}
--
......@@ -1192,4 +1191,3 @@ stgArity :: Id -> HowBound -> Arity
stgArity _ (LetBound _ arity) = arity
stgArity f ImportBound = idArity f
stgArity _ LambdaBound = 0
\end{code}
compiler/stgSyn/StgLint.lhs → compiler/stgSyn/StgLint.hs
View file @ 612e5736
%
% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%
{-
(c) The GRASP/AQUA Project, Glasgow University, 1993-1998
\section[StgLint]{A ``lint'' pass to check for Stg correctness}
-}
\begin{code}
{-# LANGUAGE CPP #-}
module StgLint ( lintStgBindings ) where
......@@ -23,7 +23,7 @@ import ErrUtils ( MsgDoc, Severity(..), mkLocMessage )
import TypeRep
import Type
import TyCon
import Util
import Util
import SrcLoc
import Outputable
import FastString
......@@ -34,8 +34,8 @@ import Control.Monad
import Data.Function
#include "HsVersions.h"
\end{code}
{-
Checks for
(a) *some* type errors
(b) locally-defined variables used but not defined
......@@ -52,15 +52,15 @@ for Stg code that is currently perfectly acceptable for code
generation. Solution: don't use it! (KSW 2000-05).
%************************************************************************
%* *
************************************************************************
* *
\subsection{``lint'' for various constructs}
%* *
%************************************************************************
* *
************************************************************************
@lintStgBindings@ is the top-level interface function.
-}
\begin{code}
lintStgBindings :: String -> [StgBinding] -> [StgBinding]
lintStgBindings whodunnit binds
......@@ -82,10 +82,7 @@ lintStgBindings whodunnit binds
binders <- lintStgBinds bind
addInScopeVars binders $
lint_binds binds
\end{code}
\begin{code}
lintStgArg :: StgArg -> LintM (Maybe Type)
lintStgArg (StgLitArg lit) = return (Just (literalType lit))
lintStgArg (StgVarArg v) = lintStgVar v
......@@ -93,9 +90,7 @@ lintStgArg (StgVarArg v) = lintStgVar v
lintStgVar :: Id -> LintM (Maybe Kind)
lintStgVar v = do checkInScope v
return (Just (idType v))
\end{code}
\begin{code}
lintStgBinds :: StgBinding -> LintM [Id] -- Returns the binders
lintStgBinds (StgNonRec binder rhs) = do
lint_binds_help (binder,rhs)
......@@ -131,9 +126,7 @@ lint_binds_help (binder, rhs)
return ()
where
binder_ty = idType binder
\end{code}
\begin{code}
lintStgRhs :: StgRhs -> LintM (Maybe Type) -- Just ty => type is exact
lintStgRhs (StgRhsClosure _ _ _ _ _ [] expr)
......@@ -150,9 +143,7 @@ lintStgRhs (StgRhsCon _ con args) = runMaybeT $ do
MaybeT $ checkFunApp con_ty arg_tys (mkRhsConMsg con_ty arg_tys)
where
con_ty = dataConRepType con
\end{code}
\begin{code}
lintStgExpr :: StgExpr -> LintM (Maybe Type) -- Just ty => type is exact
lintStgExpr (StgLit l) = return (Just (literalType l))
......@@ -274,16 +265,15 @@ lintAlt scrut_ty (DataAlt con, args, _, rhs) = do
-- We give it its own copy, so it isn't overloaded.
elem _ [] = False
elem x (y:ys) = x==y || elem x ys
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
\subsection[lint-monad]{The Lint monad}
%* *
%************************************************************************
* *
************************************************************************
-}
\begin{code}
newtype LintM a = LintM
{ unLintM :: [LintLocInfo] -- Locations
-> IdSet -- Local vars in scope
......@@ -312,9 +302,7 @@ pp_binders bs
where
pp_binder b
= hsep [ppr b, dcolon, ppr (idType b)]
\end{code}
\begin{code}
initL :: LintM a -> Maybe MsgDoc
initL (LintM m)
= case (m [] emptyVarSet emptyBag) of { (_, errs) ->
......@@ -345,9 +333,7 @@ thenL_ :: LintM a -> LintM b -> LintM b
thenL_ m k = LintM $ \loc scope errs
-> case unLintM m loc scope errs of
(_, errs') -> unLintM k loc scope errs'
\end{code}
\begin{code}
checkL :: Bool -> MsgDoc -> LintM ()
checkL True _ = return ()
checkL False msg = addErrL msg
......@@ -382,15 +368,15 @@ addInScopeVars ids m = LintM $ \loc scope errs
-- then id
-- else pprTrace "Shadowed vars:" (ppr (varSetElems shadowed))) $
unLintM m loc (scope `unionVarSet` new_set) errs
\end{code}
{-
Checking function applications: we only check that the type has the
right *number* of arrows, we don't actually compare the types. This
is because we can't expect the types to be equal - the type
applications and type lambdas that we use to calculate accurate types
have long since disappeared.
-}
\begin{code}
checkFunApp :: Type -- The function type
-> [Type] -- The arg type(s)
-> MsgDoc -- Error message
......@@ -410,9 +396,9 @@ checkFunApp fun_ty arg_tys msg
cfa accurate fun_ty [] -- Args have run out; that's fine
= (if accurate then Just fun_ty else Nothing, Nothing)
cfa accurate fun_ty arg_tys@(arg_ty':arg_tys')
cfa accurate fun_ty arg_tys@(arg_ty':arg_tys')
| Just (arg_ty, res_ty) <- splitFunTy_maybe fun_ty
= if accurate && not (arg_ty `stgEqType` arg_ty')
= if accurate && not (arg_ty `stgEqType` arg_ty')
then (Nothing, Just msg) -- Arg type mismatch
else cfa accurate res_ty arg_tys'
......@@ -421,7 +407,7 @@ checkFunApp fun_ty arg_tys msg
| Just (tc,tc_args) <- splitTyConApp_maybe fun_ty
, isNewTyCon tc
= if length tc_args < tyConArity tc
= if length tc_args < tyConArity tc
then WARN( True, text "cfa: unsaturated newtype" <+> ppr fun_ty $$ msg )
(Nothing, Nothing) -- This is odd, but I've seen it
else cfa False (newTyConInstRhs tc tc_args) arg_tys
......@@ -432,9 +418,7 @@ checkFunApp fun_ty arg_tys msg
| otherwise
= (Nothing, Nothing)
\end{code}
\begin{code}
stgEqType :: Type -> Type -> Bool
-- Compare types, but crudely because we have discarded
-- both casts and type applications, so types might look
......@@ -443,7 +427,7 @@ stgEqType :: Type -> Type -> Bool
--
-- Fundamentally this is a losing battle because of unsafeCoerce
stgEqType orig_ty1 orig_ty2
stgEqType orig_ty1 orig_ty2
= gos (repType orig_ty1) (repType orig_ty2)
where
gos :: RepType -> RepType -> Bool
......@@ -456,18 +440,18 @@ stgEqType orig_ty1 orig_ty2
go ty1 ty2
| Just (tc1, tc_args1) <- splitTyConApp_maybe ty1
, Just (tc2, tc_args2) <- splitTyConApp_maybe ty2
, let res = if tc1 == tc2
, let res = if tc1 == tc2
then equalLength tc_args1 tc_args2 && and (zipWith (gos `on` repType) tc_args1 tc_args2)
else -- TyCons don't match; but don't bleat if either is a
-- family TyCon because a coercion might have made it
else -- TyCons don't match; but don't bleat if either is a
-- family TyCon because a coercion might have made it
-- equal to something else
(isFamilyTyCon tc1 || isFamilyTyCon tc2)
= if res then True
else
pprTrace "stgEqType: unequal" (vcat [ppr ty1, ppr ty2])
else
pprTrace "stgEqType: unequal" (vcat [ppr ty1, ppr ty2])
False
| otherwise = True -- Conservatively say "fine".
| otherwise = True -- Conservatively say "fine".
-- Type variables in particular
checkInScope :: Id -> LintM ()
......@@ -482,9 +466,7 @@ checkTys ty1 ty2 msg = LintM $ \loc _scope errs
-> if (ty1 `stgEqType` ty2)
then ((), errs)
else ((), addErr errs msg loc)
\end{code}
\begin{code}
_mkCaseAltMsg :: [StgAlt] -> MsgDoc
_mkCaseAltMsg _alts
= ($$) (text "In some case alternatives, type of alternatives not all same:")
......@@ -551,4 +533,3 @@ mkUnLiftedTyMsg binder rhs
ptext (sLit "has unlifted type") <+> quotes (ppr (idType binder)))
$$
(ptext (sLit "RHS:") <+> ppr rhs)
\end{code}
compiler/stgSyn/StgSyn.lhs → compiler/stgSyn/StgSyn.hs
View file @ 612e5736
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
{-
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
\section[StgSyn]{Shared term graph (STG) syntax for spineless-tagless code generation}
This data type represents programs just before code generation (conversion to
@Cmm@): basically, what we have is a stylised form of @CoreSyntax@, the style
being one that happens to be ideally suited to spineless tagless code
generation.
-}
\begin{code}
{-# LANGUAGE CPP #-}
module StgSyn (
......@@ -69,13 +69,13 @@ import UniqSet
import Unique ( Unique )
import Util
import VarSet ( IdSet, isEmptyVarSet )
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
\subsection{@GenStgBinding@}
%* *
%************************************************************************
* *
************************************************************************
As usual, expressions are interesting; other things are boring. Here
are the boring things [except note the @GenStgRhs@], parameterised
......@@ -83,20 +83,20 @@ with respect to binder and occurrence information (just as in
@CoreSyn@):
There is one SRT for each group of bindings.
-}
\begin{code}
data GenStgBinding bndr occ
= StgNonRec bndr (GenStgRhs bndr occ)
| StgRec [(bndr, GenStgRhs bndr occ)]
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
\subsection{@GenStgArg@}
%* *
%************************************************************************
* *
************************************************************************
-}
\begin{code}
data GenStgArg occ
= StgVarArg occ
| StgLitArg Literal
......@@ -142,22 +142,22 @@ isAddrRep _ = False
stgArgType :: StgArg -> Type
stgArgType (StgVarArg v) = idType v
stgArgType (StgLitArg lit) = literalType lit
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
\subsection{STG expressions}
%* *
%************************************************************************
* *
************************************************************************
The @GenStgExpr@ data type is parameterised on binder and occurrence
info, as before.
%************************************************************************
%* *
************************************************************************
* *
\subsubsection{@GenStgExpr@ application}
%* *
%************************************************************************
* *
************************************************************************
An application is of a function to a list of atoms [not expressions].
Operationally, we want to push the arguments on the stack and call the
......@@ -166,24 +166,26 @@ their closures first.)
There is no constructor for a lone variable; it would appear as
@StgApp var [] _@.
\begin{code}
-}
type GenStgLiveVars occ = UniqSet occ
data GenStgExpr bndr occ
= StgApp
occ -- function
[GenStgArg occ] -- arguments; may be empty
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
\subsubsection{@StgConApp@ and @StgPrimApp@---saturated applications}
%* *
%************************************************************************
* *
************************************************************************
There are a specialised forms of application, for constructors,
primitives, and literals.
\begin{code}
-}
| StgLit Literal
-- StgConApp is vital for returning unboxed tuples
......@@ -196,32 +198,32 @@ primitives, and literals.
Type -- Result type
-- We need to know this so that we can
-- assign result registers
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
\subsubsection{@StgLam@}
%* *
%************************************************************************
* *
************************************************************************
StgLam is used *only* during CoreToStg's work. Before CoreToStg has
finished it encodes (\x -> e) as (let f = \x -> e in f)
-}
\begin{code}
| StgLam
[bndr]
StgExpr -- Body of lambda
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
\subsubsection{@GenStgExpr@: case-expressions}
%* *
%************************************************************************
* *
************************************************************************
This has the same boxed/unboxed business as Core case expressions.
\begin{code}
-}
| StgCase
(GenStgExpr bndr occ)
-- the thing to examine
......@@ -248,13 +250,13 @@ This has the same boxed/unboxed business as Core case expressions.
[GenStgAlt bndr occ]
-- The DEFAULT case is always *first*
-- if it is there at all
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
\subsubsection{@GenStgExpr@: @let(rec)@-expressions}
%* *
%************************************************************************
* *
************************************************************************
The various forms of let(rec)-expression encode most of the
interesting things we want to do.
......@@ -341,7 +343,8 @@ in e
\end{enumerate}
And so the code for let(rec)-things:
\begin{code}
-}
| StgLet
(GenStgBinding bndr occ) -- right hand sides (see below)
(GenStgExpr bndr occ) -- body
......@@ -358,50 +361,51 @@ And so the code for let(rec)-things:
(GenStgBinding bndr occ) -- right hand sides (see below)
(GenStgExpr bndr occ) -- body
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
\subsubsection{@GenStgExpr@: @scc@ expressions}
%* *
%************************************************************************
* *
************************************************************************
For @scc@ expressions we introduce a new STG construct.
-}
\begin{code}
| StgSCC
CostCentre -- label of SCC expression
!Bool -- bump the entry count?
!Bool -- push the cost centre?
(GenStgExpr bndr occ) -- scc expression
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
\subsubsection{@GenStgExpr@: @hpc@ expressions}
%* *
%************************************************************************
* *
************************************************************************
Finally for @hpc@ expressions we introduce a new STG construct.
-}
\begin{code}
| StgTick
Module -- the module of the source of this tick
Int -- tick number
(GenStgExpr bndr occ) -- sub expression
-- END of GenStgExpr
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
\subsection{STG right-hand sides}
%* *
%************************************************************************
* *
************************************************************************
Here's the rest of the interesting stuff for @StgLet@s; the first
flavour is for closures:
\begin{code}
-}
data GenStgRhs bndr occ
= StgRhsClosure
CostCentreStack -- CCS to be attached (default is CurrentCCS)
......@@ -413,7 +417,8 @@ data GenStgRhs bndr occ
[bndr] -- arguments; if empty, then not a function;
-- as above, order is important.
(GenStgExpr bndr occ) -- body
\end{code}
{-
An example may be in order. Consider:
\begin{verbatim}
let t = \x -> \y -> ... x ... y ... p ... q in e
......@@ -427,7 +432,8 @@ offsets from @Node@ into the closure, and the code ptr for the closure
will be exactly that in parentheses above.
The second flavour of right-hand-side is for constructors (simple but important):
\begin{code}
-}
| StgRhsCon
CostCentreStack -- CCS to be attached (default is CurrentCCS).
-- Top-level (static) ones will end up with
......@@ -456,10 +462,9 @@ rhsHasCafRefs (StgRhsCon _ _ args)
stgArgHasCafRefs :: GenStgArg Id -> Bool
stgArgHasCafRefs (StgVarArg id) = mayHaveCafRefs (idCafInfo id)
stgArgHasCafRefs _ = False
\end{code}
Here's the @StgBinderInfo@ type, and its combining op:
\begin{code}
-- Here's the @StgBinderInfo@ type, and its combining op:
data StgBinderInfo
= NoStgBinderInfo
| SatCallsOnly -- All occurrences are *saturated* *function* calls
......@@ -484,13 +489,13 @@ combineStgBinderInfo _ _ = NoStgBinderInfo
pp_binder_info :: StgBinderInfo -> SDoc
pp_binder_info NoStgBinderInfo = empty
pp_binder_info SatCallsOnly = ptext (sLit "sat-only")
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
\subsection[Stg-case-alternatives]{STG case alternatives}
%* *
%************************************************************************
* *
************************************************************************
Very like in @CoreSyntax@ (except no type-world stuff).
......@@ -502,8 +507,8 @@ constructor might not have all the constructors visible. So
mkStgAlgAlts (in CoreToStg) ensures that it gets the TyCon from the
constructors or literals (which are guaranteed to have the Real McCoy)
rather than from the scrutinee type.
-}
\begin{code}
type GenStgAlt bndr occ
= (AltCon, -- alts: data constructor,
[bndr], -- constructor's parameters,
......@@ -518,30 +523,30 @@ data AltType
| UbxTupAlt Int -- Unboxed tuple of this arity
| AlgAlt TyCon -- Algebraic data type; the AltCons will be DataAlts
| PrimAlt TyCon -- Primitive data type; the AltCons will be LitAlts
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
\subsection[Stg]{The Plain STG parameterisation}
%* *
%************************************************************************
* *
************************************************************************
This happens to be the only one we use at the moment.
-}
\begin{code}
type StgBinding = GenStgBinding Id Id
type StgArg = GenStgArg Id
type StgLiveVars = GenStgLiveVars Id
type StgExpr = GenStgExpr Id Id
type StgRhs = GenStgRhs Id Id
type StgAlt = GenStgAlt Id Id
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
\subsubsection[UpdateFlag-datatype]{@UpdateFlag@}
%* *
%************************************************************************
* *
************************************************************************
This is also used in @LambdaFormInfo@ in the @ClosureInfo@ module.
......@@ -550,8 +555,8 @@ updated or blackholed. An @Updatable@ closure should be updated after
evaluation (and may be blackholed during evaluation). A @SingleEntry@
closure will only be entered once, and so need not be updated but may
safely be blackholed.
-}
\begin{code}
data UpdateFlag = ReEntrant | Updatable | SingleEntry
instance Outputable UpdateFlag where
......@@ -564,19 +569,19 @@ isUpdatable :: UpdateFlag -> Bool
isUpdatable ReEntrant = False
isUpdatable SingleEntry = False
isUpdatable Updatable = True
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
\subsubsection{StgOp}
%* *
%************************************************************************
* *
************************************************************************
An StgOp allows us to group together PrimOps and ForeignCalls.
It's quite useful to move these around together, notably
in StgOpApp and COpStmt.
-}
\begin{code}
data StgOp
= StgPrimOp PrimOp
......@@ -586,14 +591,13 @@ data StgOp
-- The Unique is occasionally needed by the C pretty-printer
-- (which lacks a unique supply), notably when generating a
-- typedef for foreign-export-dynamic
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
\subsubsection[Static Reference Tables]{@SRT@}
%* *
%************************************************************************
* *
************************************************************************
There is one SRT per top-level function group. Each local binding and
case expression within this binding group has a subrange of the whole
......@@ -601,8 +605,8 @@ SRT, expressed as an offset and length.
In CoreToStg we collect the list of CafRefs at each SRT site, which is later
converted into the length and offset form by the SRT pass.
-}
\begin{code}
data SRT
= NoSRT