Skip to content
GitLab
Commit 4d5f83a8 authored by Austin Seipp's avatar Austin Seipp
Browse files

compiler: de-lhs deSugar/ 



Signed-off-by: default avatarAustin Seipp <austin@well-typed.com>
parent b57ff272
Hide whitespace changes
Inline Side-by-side
compiler/deSugar/Check.lhs → compiler/deSugar/Check.hs
View file @ 4d5f83a8
%
% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1997-1998
%
% Author: Juan J. Quintela <quintela@krilin.dc.fi.udc.es>
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1997-1998
Author: Juan J. Quintela <quintela@krilin.dc.fi.udc.es>
-}
\begin{code}
{-# LANGUAGE CPP #-}
module Check ( check , ExhaustivePat ) where
......@@ -29,8 +29,8 @@ import Util
import BasicTypes
import Outputable
import FastString
\end{code}
{-
This module performs checks about if one list of equations are:
\begin{itemize}
\item Overlapped
......@@ -95,8 +95,8 @@ Then we need to use InPats.
Juan Quintela 5 JUL 1998\\
User-friendliness and compiler writers are no friends.
\end{quotation}
-}
\begin{code}
type WarningPat = InPat Name
type ExhaustivePat = ([WarningPat], [(Name, [HsLit])])
type EqnNo = Int
......@@ -122,11 +122,8 @@ untidy_exhaustive (pats, messages) =
untidy_message :: (Name, [HsLit]) -> (Name, [HsLit])
untidy_message (string, lits) = (string, map untidy_lit lits)
\end{code}
The function @untidy@ does the reverse work of the @tidy_pat@ function.
\begin{code}
-- The function @untidy@ does the reverse work of the @tidy_pat@ function.
type NeedPars = Bool
......@@ -144,9 +141,9 @@ untidy b (L loc p) = L loc (untidy' b p)
untidy' _ (LitPat lit) = LitPat (untidy_lit lit)
untidy' _ p@(ConPatIn _ (PrefixCon [])) = p
untidy' b (ConPatIn name ps) = pars b (L loc (ConPatIn name (untidy_con ps)))
untidy' _ (ListPat pats ty Nothing) = ListPat (map untidy_no_pars pats) ty Nothing
untidy' _ (ListPat pats ty Nothing) = ListPat (map untidy_no_pars pats) ty Nothing
untidy' _ (TuplePat pats box tys) = TuplePat (map untidy_no_pars pats) box tys
untidy' _ (ListPat _ _ (Just _)) = panic "Check.untidy: Overloaded ListPat"
untidy' _ (ListPat _ _ (Just _)) = panic "Check.untidy: Overloaded ListPat"
untidy' _ (PArrPat _ _) = panic "Check.untidy: Shouldn't get a parallel array here!"
untidy' _ (SigPatIn _ _) = panic "Check.untidy: SigPat"
untidy' _ (LazyPat {}) = panic "Check.untidy: LazyPat"
......@@ -177,8 +174,8 @@ pars _ p = unLoc p
untidy_lit :: HsLit -> HsLit
untidy_lit (HsCharPrim src c) = HsChar src c
untidy_lit lit = lit
\end{code}
{-
This equation is the same that check, the only difference is that the
boring work is done, that work needs to be done only once, this is
the reason top have two functions, check is the external interface,
......@@ -203,9 +200,7 @@ There are several cases:
vars in the first column, we actuate in consequence.
\end{itemize}
\begin{code}
-}
check' :: [(EqnNo, EquationInfo)]
-> ([ExhaustivePat], -- Pattern scheme that might not be matched at all
......@@ -213,7 +208,7 @@ check' :: [(EqnNo, EquationInfo)]
check' [] = ([],emptyUniqSet)
-- Was ([([],[])], emptyUniqSet)
-- But that (a) seems weird, and (b) triggered Trac #7669
-- But that (a) seems weird, and (b) triggered Trac #7669
-- So now I'm just doing the simple obvious thing
check' ((n, EqnInfo { eqn_pats = ps, eqn_rhs = MatchResult can_fail _ }) : rs)
......@@ -242,36 +237,34 @@ check' qs
some_constructors = any is_con first_pats
some_literals = any is_lit first_pats
only_vars = all is_var first_pats
\end{code}
{-
Here begins the code to deal with literals, we need to split the matrix
in different matrix beginning by each literal and a last matrix with the
rest of values.
-}
\begin{code}
split_by_literals :: [(EqnNo, EquationInfo)] -> ([ExhaustivePat], EqnSet)
split_by_literals qs = process_literals used_lits qs
where
used_lits = get_used_lits qs
\end{code}
{-
@process_explicit_literals@ is a function that process each literal that appears
in the column of the matrix.
-}
\begin{code}
process_explicit_literals :: [HsLit] -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
process_explicit_literals lits qs = (concat pats, unionManyUniqSets indexs)
where
pats_indexs = map (\x -> construct_literal_matrix x qs) lits
(pats,indexs) = unzip pats_indexs
\end{code}
{-
@process_literals@ calls @process_explicit_literals@ to deal with the literals
that appears in the matrix and deal also with the rest of the cases. It
must be one Variable to be complete.
\begin{code}
-}
process_literals :: [HsLit] -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
process_literals used_lits qs
......@@ -285,12 +278,12 @@ process_literals used_lits qs
pats_default = [(nlWildPatName:ps,constraints) |
(ps,constraints) <- (pats')] ++ pats
indexs_default = unionUniqSets indexs' indexs
\end{code}
{-
Here we have selected the literal and we will select all the equations that
begins for that literal and create a new matrix.
-}
\begin{code}
construct_literal_matrix :: HsLit -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
construct_literal_matrix lit qs =
(map (\ (xs,ys) -> (new_lit:xs,ys)) pats,indexs)
......@@ -307,12 +300,12 @@ remove_first_column_lit lit qs
where
shift_pat eqn@(EqnInfo { eqn_pats = _:ps}) = eqn { eqn_pats = ps }
shift_pat _ = panic "Check.shift_var: no patterns"
\end{code}
{-
This function splits the equations @qs@ in groups that deal with the
same constructor.
-}
\begin{code}
split_by_constructor :: [(EqnNo, EquationInfo)] -> ([ExhaustivePat], EqnSet)
split_by_constructor qs
| null used_cons = ([], mkUniqSet $ map fst qs)
......@@ -321,19 +314,19 @@ split_by_constructor qs
where
used_cons = get_used_cons qs
unused_cons = get_unused_cons used_cons
\end{code}
{-
The first column of the patterns matrix only have vars, then there is
nothing to do.
-}
\begin{code}
first_column_only_vars :: [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
first_column_only_vars qs
= (map (\ (xs,ys) -> (nlWildPatName:xs,ys)) pats,indexs)
where
(pats, indexs) = check' (map remove_var qs)
\end{code}
{-
This equation takes a matrix of patterns and split the equations by
constructor, using all the constructors that appears in the first column
of the pattern matching.
......@@ -341,8 +334,8 @@ of the pattern matching.
We can need a default clause or not ...., it depends if we used all the
constructors or not explicitly. The reasoning is similar to @process_literals@,
the difference is that here the default case is not always needed.
-}
\begin{code}
no_need_default_case :: [Pat Id] -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
no_need_default_case cons qs = (concat pats, unionManyUniqSets indexs)
where
......@@ -369,8 +362,8 @@ construct_matrix con qs =
(map (make_con con) pats,indexs)
where
(pats,indexs) = (check' (remove_first_column con qs))
\end{code}
{-
Here remove first column is more difficult that with literals due to the fact
that constructors can have arguments.
......@@ -384,8 +377,8 @@ is transformed in:
x xs y
_ _ y
\end{verbatim}
-}
\begin{code}
remove_first_column :: Pat Id -- Constructor
-> [(EqnNo, EquationInfo)]
-> [(EqnNo, EquationInfo)]
......@@ -536,8 +529,8 @@ is_var_lit _ (WildPat _) = True
is_var_lit lit pat
| Just lit' <- get_lit pat = lit == lit'
| otherwise = False
\end{code}
{-
The difference beteewn @make_con@ and @make_whole_con@ is that
@make_wole_con@ creates a new constructor with all their arguments, and
@make_con@ takes a list of argumntes, creates the contructor getting their
......@@ -570,12 +563,12 @@ In particular:
\\ @((:) x xs)@ & returns to be & @(x:xs)@
\\ @(x:(...:[])@ & returns to be & @[x,...]@
\end{tabular}
%
The difficult case is the third one becouse we need to follow all the
contructors until the @[]@ to know that we need to use the second case,
not the second. \fbox{\ ???\ }
%
\begin{code}
-}
isInfixCon :: DataCon -> Bool
isInfixCon con = isDataSymOcc (getOccName con)
......@@ -629,8 +622,8 @@ make_whole_con con | isInfixCon con = nlInfixConPat name
where
name = getName con
pats = [nlWildPatName | _ <- dataConOrigArgTys con]
\end{code}
{-
------------------------------------------------------------------------
Tidying equations
------------------------------------------------------------------------
......@@ -640,8 +633,8 @@ that is, it removes syntactic sugar, reducing the number of cases that
must be handled by the main checking algorithm. One difference is
that here we can do *all* the tidying at once (recursively), rather
than doing it incrementally.
-}
\begin{code}
tidy_eqn :: EquationInfo -> EquationInfo
tidy_eqn eqn = eqn { eqn_pats = map tidy_pat (eqn_pats eqn),
eqn_rhs = tidy_rhs (eqn_rhs eqn) }
......@@ -778,4 +771,3 @@ tidy_con con (RecCon (HsRecFields fs _))
insertNm nm p (x@(n,_):xs)
| nm == n = (nm,p):xs
| otherwise = x : insertNm nm p xs
\end{code}
compiler/deSugar/Coverage.lhs → compiler/deSugar/Coverage.hs
View file @ 4d5f83a8
%
% (c) Galois, 2006
% (c) University of Glasgow, 2007
%
\begin{code}
{-
(c) Galois, 2006
(c) University of Glasgow, 2007
-}
{-# LANGUAGE NondecreasingIndentation #-}
module Coverage (addTicksToBinds, hpcInitCode) where
......@@ -43,16 +43,15 @@ import Trace.Hpc.Util
import BreakArray
import Data.Map (Map)
import qualified Data.Map as Map
\end{code}
{-
************************************************************************
* *
* The main function: addTicksToBinds
* *
************************************************************************
-}
%************************************************************************
%* *
%* The main function: addTicksToBinds
%* *
%************************************************************************
\begin{code}
addTicksToBinds
:: DynFlags
-> Module
......@@ -526,7 +525,7 @@ addTickHsExpr (ExplicitList ty wit es) =
liftM3 ExplicitList
(return ty)
(addTickWit wit)
(mapM (addTickLHsExpr) es)
(mapM (addTickLHsExpr) es)
where addTickWit Nothing = return Nothing
addTickWit (Just fln) = do fln' <- addTickHsExpr fln
return (Just fln')
......@@ -808,7 +807,7 @@ addTickHsCmd (HsCmdArrForm e fix cmdtop) =
(return fix)
(mapM (liftL (addTickHsCmdTop)) cmdtop)
addTickHsCmd (HsCmdCast co cmd)
addTickHsCmd (HsCmdCast co cmd)
= liftM2 HsCmdCast (return co) (addTickHsCmd cmd)
-- Others should never happen in a command context.
......@@ -918,9 +917,7 @@ liftL :: (Monad m) => (a -> m a) -> Located a -> m (Located a)
liftL f (L loc a) = do
a' <- f a
return $ L loc a'
\end{code}
\begin{code}
data TickTransState = TT { tickBoxCount:: Int
, mixEntries :: [MixEntry_]
}
......@@ -1164,18 +1161,12 @@ mkHpcPos _ = panic "bad source span; expected such spans to be filtered out"
hpcSrcSpan :: SrcSpan
hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals")
\end{code}
\begin{code}
matchesOneOfMany :: [LMatch Id body] -> Bool
matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1
where
matchCount (L _ (Match _pats _ty (GRHSs grhss _binds))) = length grhss
\end{code}
\begin{code}
type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel)
-- For the hash value, we hash everything: the file name,
......@@ -1187,13 +1178,13 @@ type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel)
mixHash :: FilePath -> UTCTime -> Int -> [MixEntry] -> Int
mixHash file tm tabstop entries = fromIntegral $ hashString
(show $ Mix file tm 0 tabstop entries)
\end{code}
%************************************************************************
%* *
%* initialisation
%* *
%************************************************************************
{-
************************************************************************
* *
* initialisation
* *
************************************************************************
Each module compiled with -fhpc declares an initialisation function of
the form `hpc_init_<module>()`, which is emitted into the _stub.c file
......@@ -1207,8 +1198,8 @@ static void hpc_init_Main(void) __attribute__((constructor));
static void hpc_init_Main(void)
{extern StgWord64 _hpc_tickboxes_Main_hpc[];
hs_hpc_module("Main",8,1150288664,_hpc_tickboxes_Main_hpc);}
-}
\begin{code}
hpcInitCode :: Module -> HpcInfo -> SDoc
hpcInitCode _ (NoHpcInfo {}) = Outputable.empty
hpcInitCode this_mod (HpcInfo tickCount hashNo)
......@@ -1240,4 +1231,3 @@ hpcInitCode this_mod (HpcInfo tickCount hashNo)
= module_name
| otherwise
= package_name <> char '/' <> module_name
\end{code}
compiler/deSugar/Desugar.lhs → compiler/deSugar/Desugar.hs
View file @ 4d5f83a8
%
% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
The Desugarer: turning HsSyn into Core.
-}
\begin{code}
{-# LANGUAGE CPP #-}
module Desugar ( deSugar, deSugarExpr ) where
......@@ -52,15 +52,15 @@ import OrdList
import Data.List
import Data.IORef
import Control.Monad( when )
\end{code}
%************************************************************************
%* *
%* The main function: deSugar
%* *
%************************************************************************
{-
************************************************************************
* *
* The main function: deSugar
* *
************************************************************************
-}
\begin{code}
-- | Main entry point to the desugarer.
deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages, Maybe ModGuts)
-- Can modify PCS by faulting in more declarations
......@@ -212,8 +212,8 @@ combineEvBinds (NonRec b r : bs) val_prs
| otherwise = NonRec b r : combineEvBinds bs val_prs
combineEvBinds (Rec prs : bs) val_prs
= combineEvBinds bs (prs ++ val_prs)
\end{code}
{-
Note [Top-level evidence]
~~~~~~~~~~~~~~~~~~~~~~~~~
Top-level evidence bindings may be mutually recursive with the top-level value
......@@ -223,9 +223,8 @@ when computing dependencies.
So we pull out the type/coercion variables (which are in dependency order),
and Rec the rest.
-}
\begin{code}
deSugarExpr :: HscEnv -> LHsExpr Id -> IO (Messages, Maybe CoreExpr)
deSugarExpr hsc_env tc_expr
......@@ -249,15 +248,15 @@ deSugarExpr hsc_env tc_expr
Just expr -> dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr expr)
; return (msgs, mb_core_expr) }
\end{code}
%************************************************************************
%* *
%* Add rules and export flags to binders
%* *
%************************************************************************
{-
************************************************************************
* *
* Add rules and export flags to binders
* *
************************************************************************
-}
\begin{code}
addExportFlagsAndRules
:: HscTarget -> NameSet -> NameSet -> [CoreRule]
-> [(Id, t)] -> [(Id, t)]
......@@ -299,9 +298,8 @@ addExportFlagsAndRules target exports keep_alive rules prs
is_exported :: Name -> Bool
is_exported | targetRetainsAllBindings target = isExternalName
| otherwise = (`elemNameSet` exports)
\end{code}
{-
Note [Adding export flags]
~~~~~~~~~~~~~~~~~~~~~~~~~~
Set the no-discard flag if either
......@@ -338,13 +336,12 @@ Reason
thereby get dropped
%************************************************************************
%* *
%* Desugaring transformation rules
%* *
%************************************************************************
\begin{code}
************************************************************************
* *
* Desugaring transformation rules
* *
************************************************************************
-}
dsRule :: LRuleDecl Id -> DsM (Maybe CoreRule)
dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
......@@ -378,7 +375,7 @@ dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
inline_shadows_rule -- Function can be inlined before rule fires
| wopt Opt_WarnInlineRuleShadowing dflags
, isLocalId fn_id || hasSomeUnfolding (idUnfolding fn_id)
, isLocalId fn_id || hasSomeUnfolding (idUnfolding fn_id)
-- If imported with no unfolding, no worries
= case (idInlineActivation fn_id, act) of
(NeverActive, _) -> False
......@@ -422,8 +419,7 @@ unfold_coerce bndrs lhs rhs = do
(bndrs,wrap) <- go vs
return (v:bndrs, wrap)
\end{code}
{-
Note [Desugaring RULE left hand sides]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For the LHS of a RULE we do *not* want to desugar
......@@ -455,13 +451,13 @@ corresponding `co :: a ~#R b` and wrap the LHS and the RHS in
`let c = MkCoercible co in ...`. This is later simplified to the desired form
by simpleOptExpr (for the LHS) resp. the simplifiers (for the RHS).
%************************************************************************
%* *
%* Desugaring vectorisation declarations
%* *
%************************************************************************
************************************************************************
* *
* Desugaring vectorisation declarations
* *
************************************************************************
-}
\begin{code}
dsVect :: LVectDecl Id -> DsM CoreVect
dsVect (L loc (HsVect (L _ v) rhs))
= putSrcSpanDs loc $
......@@ -486,4 +482,3 @@ dsVect (L _loc (HsVectInstOut inst))
= return $ VectInst (instanceDFunId inst)
dsVect vi@(L _ (HsVectInstIn _))
= pprPanic "Desugar.dsVect: unexpected 'HsVectInstIn'" (ppr vi)
\end{code}
compiler/deSugar/DsArrows.lhs → compiler/deSugar/DsArrows.hs
View file @ 4d5f83a8
%
% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
Desugaring arrow commands
-}
\begin{code}
{-# LANGUAGE CPP #-}
module DsArrows ( dsProcExpr ) where
......@@ -48,9 +48,7 @@ import SrcLoc
import ListSetOps( assocDefault )
import FastString
import Data.List
\end{code}
\begin{code}
data DsCmdEnv = DsCmdEnv {
arr_id, compose_id, first_id, app_id, choice_id, loop_id :: CoreExpr
}
......@@ -137,12 +135,12 @@ mkSndExpr a_ty b_ty = do
pair_var <- newSysLocalDs (mkCorePairTy a_ty b_ty)
return (Lam pair_var
(coreCasePair pair_var a_var b_var (Var b_var)))
\end{code}
{-
Build case analysis of a tuple. This cannot be done in the DsM monad,
because the list of variables is typically not yet defined.
-}
\begin{code}
-- coreCaseTuple [u1..] v [x1..xn] body
-- = case v of v { (x1, .., xn) -> body }
-- But the matching may be nested if the tuple is very big
......@@ -155,9 +153,7 @@ coreCasePair :: Id -> Id -> Id -> CoreExpr -> CoreExpr
coreCasePair scrut_var var1 var2 body
= Case (Var scrut_var) scrut_var (exprType body)
[(DataAlt (tupleCon BoxedTuple 2), [var1, var2], body)]
\end{code}
\begin{code}
mkCorePairTy :: Type -> Type -> Type
mkCorePairTy t1 t2 = mkBoxedTupleTy [t1, t2]
......@@ -166,8 +162,8 @@ mkCorePairExpr e1 e2 = mkCoreTup [e1, e2]
mkCoreUnitExpr :: CoreExpr
mkCoreUnitExpr = mkCoreTup []
\end{code}
{-
The input is divided into a local environment, which is a flat tuple
(unless it's too big), and a stack, which is a right-nested pair.
In general, the input has the form
......@@ -176,8 +172,8 @@ In general, the input has the form
where xi are the environment values, and si the ones on the stack,
with s1 being the "top", the first one to be matched with a lambda.
-}
\begin{code}
envStackType :: [Id] -> Type -> Type
envStackType ids stack_ty = mkCorePairTy (mkBigCoreVarTupTy ids) stack_ty
......@@ -250,17 +246,12 @@ matchVarStack (param_id:param_ids) stack_id body = do
(tail_id, tail_code) <- matchVarStack param_ids stack_id body
pair_id <- newSysLocalDs (mkCorePairTy (idType param_id) (idType tail_id))
return (pair_id, coreCasePair pair_id param_id tail_id tail_code)
\end{code}
\begin{code}
mkHsEnvStackExpr :: [Id] -> Id -> LHsExpr Id
mkHsEnvStackExpr env_ids stack_id
= mkLHsTupleExpr [mkLHsVarTuple env_ids, nlHsVar stack_id]
\end{code}
Translation of arrow abstraction
\begin{code}
-- Translation of arrow abstraction
-- D; xs |-a c : () --> t' ---> c'
-- --------------------------
......@@ -287,8 +278,8 @@ dsProcExpr pat (L _ (HsCmdTop cmd _unitTy cmd_ty ids)) = do
(Lam var match_code)
core_cmd
return (mkLets meth_binds proc_code)
\end{code}
{-
Translation of a command judgement of the form
D; xs |-a c : stk --> t
......@@ -296,8 +287,8 @@ Translation of a command judgement of the form
to an expression e such that
D |- e :: a (xs, stk) t
-}
\begin{code}
dsLCmd :: DsCmdEnv -> IdSet -> Type -> Type -> LHsCmd Id -> [Id]
-> DsM (CoreExpr, IdSet)
dsLCmd ids local_vars stk_ty res_ty cmd env_ids
......@@ -483,8 +474,8 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdIf mb_fun cond then_cmd else_cmd)
core_if
(do_choice ids then_ty else_ty res_ty core_then core_else),
fvs_cond `unionVarSet` fvs_then `unionVarSet` fvs_else)