summaryrefslogtreecommitdiff
path: root/ghc/compiler
diff options
context:
space:
mode:
authorsimonpj <unknown>2000-11-15 14:37:10 +0000
committersimonpj <unknown>2000-11-15 14:37:10 +0000
commit8b653a82cdad2eef86395616256304ae4cb18b2b (patch)
treef523be6d5aa5a210e7f136548a01cbe939f811c8 /ghc/compiler
parent4631557d51ec5573faa28c2062a861e630ab4993 (diff)
downloadhaskell-8b653a82cdad2eef86395616256304ae4cb18b2b.tar.gz
[project @ 2000-11-15 14:37:08 by simonpj]
The main thing in this commit is to change StgAlts so that it carries a TyCon, and not a Type. Furthermore, the TyCon is derived from the alternatives, so it should have its constructors etc, even if there's a module loop involved, so that some versions of the TyCon don't have the constructors visible. There's a comment in StgSyn.lhs, with the type decl for StgAlts Also: a start on hscExpr in HscMain.
Diffstat (limited to 'ghc/compiler')
-rw-r--r--ghc/compiler/codeGen/CgCase.lhs205
-rw-r--r--ghc/compiler/codeGen/CgExpr.lhs5
-rw-r--r--ghc/compiler/ghci/StgInterp.lhs6
-rw-r--r--ghc/compiler/main/ErrUtils.lhs5
-rw-r--r--ghc/compiler/main/HscMain.lhs28
-rw-r--r--ghc/compiler/profiling/SCCfinal.lhs8
-rw-r--r--ghc/compiler/rename/Rename.lhs73
-rw-r--r--ghc/compiler/rename/RnMonad.lhs91
-rw-r--r--ghc/compiler/simplStg/LambdaLift.lhs8
-rw-r--r--ghc/compiler/simplStg/SRT.lhs2
-rw-r--r--ghc/compiler/simplStg/StgVarInfo.lhs8
-rw-r--r--ghc/compiler/stgSyn/CoreToStg.lhs43
-rw-r--r--ghc/compiler/stgSyn/StgLint.lhs20
-rw-r--r--ghc/compiler/stgSyn/StgSyn.lhs55
-rw-r--r--ghc/compiler/typecheck/TcDeriv.lhs5
15 files changed, 297 insertions, 265 deletions
diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs
index 07b1db4135..1d58b629a7 100644
--- a/ghc/compiler/codeGen/CgCase.lhs
+++ b/ghc/compiler/codeGen/CgCase.lhs
@@ -1,7 +1,7 @@
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgCase.lhs,v 1.49 2000/11/10 15:12:51 simonpj Exp $
+% $Id: CgCase.lhs,v 1.50 2000/11/15 14:37:08 simonpj Exp $
%
%********************************************************
%* *
@@ -48,18 +48,13 @@ import CLabel ( mkVecTblLabel, mkClosureTblLabel,
import ClosureInfo ( mkLFArgument )
import CmdLineOpts ( opt_SccProfilingOn )
import Id ( Id, idPrimRep, isDeadBinder )
-import DataCon ( DataCon, dataConTag, fIRST_TAG, ConTag,
- isUnboxedTupleCon )
+import DataCon ( DataCon, dataConTag, fIRST_TAG, ConTag )
import VarSet ( varSetElems )
import Literal ( Literal )
import PrimOp ( primOpOutOfLine, PrimOp(..) )
import PrimRep ( getPrimRepSize, retPrimRepSize, PrimRep(..)
)
-import TyCon ( TyCon, isEnumerationTyCon, isUnboxedTupleTyCon,
- isFunTyCon, isPrimTyCon,
- )
-import Type ( Type, typePrimRep, splitAlgTyConApp,
- splitTyConApp_maybe, repType )
+import TyCon ( isEnumerationTyCon, isUnboxedTupleTyCon, tyConPrimRep )
import Unique ( Unique, Uniquable(..), newTagUnique )
import Maybes ( maybeToBool )
import Util
@@ -148,8 +143,8 @@ CoreToStg), so we just change its tag to 'C' (for 'case') to ensure it
doesn't clash with anything else.
\begin{code}
-cgCase (StgPrimApp op args res_ty)
- live_in_whole_case live_in_alts bndr srt (StgAlgAlts ty alts deflt)
+cgCase (StgPrimApp op args _)
+ live_in_whole_case live_in_alts bndr srt (StgAlgAlts (Just tycon) alts deflt)
| isEnumerationTyCon tycon
= getArgAmodes args `thenFC` \ arg_amodes ->
@@ -180,39 +175,44 @@ cgCase (StgPrimApp op args res_ty)
`thenC`
-- compile the alts
- cgAlgAlts NoGC uniq Nothing{-cc_slot-} False{-no semi-tagging-}
+ cgAlgAlts NoGC (getUnique bndr) Nothing{-cc_slot-} False{-no semi-tagging-}
False{-not poly case-} alts deflt
False{-don't emit yield-} `thenFC` \ (tagged_alts, deflt_c) ->
-- Do the switch
absC (mkAlgAltsCSwitch tag_amode tagged_alts deflt_c)
-
- where
- (Just (tycon,_)) = splitTyConApp_maybe res_ty
- uniq = getUnique bndr
\end{code}
Special case #2: inline PrimOps.
\begin{code}
-cgCase (StgPrimApp op args res_ty)
- live_in_whole_case live_in_alts bndr srt alts
+cgCase (StgPrimApp op args _)
+ live_in_whole_case live_in_alts bndr srt alts
| not (primOpOutOfLine op)
=
-- Get amodes for the arguments and results
getArgAmodes args `thenFC` \ arg_amodes ->
- let
- result_amodes = getPrimAppResultAmodes (getUnique bndr) alts
- in
- -- Perform the operation
getVolatileRegs live_in_alts `thenFC` \ vol_regs ->
- absC (COpStmt result_amodes op
- arg_amodes -- note: no liveness arg
- vol_regs) `thenC`
-
- -- Scrutinise the result
- cgInlineAlts bndr alts
+ case alts of
+ StgPrimAlts tycon alts deflt -- PRIMITIVE ALTS
+ -> absC (COpStmt [CTemp (getUnique bndr) (tyConPrimRep tycon)]
+ op
+ arg_amodes -- note: no liveness arg
+ vol_regs) `thenC`
+ cgPrimInlineAlts bndr tycon alts deflt
+
+ StgAlgAlts (Just tycon) [(_, args, _, rhs)] StgNoDefault
+ | isUnboxedTupleTyCon tycon -- UNBOXED TUPLE ALTS
+ -> -- no heap check, no yield, just get in there and do it.
+ absC (COpStmt [ CTemp (getUnique arg) (idPrimRep arg) | arg <- args ]
+ op
+ arg_amodes -- note: no liveness arg
+ vol_regs) `thenC`
+ mapFCs bindNewToTemp args `thenFC` \ _ ->
+ cgExpr rhs
+
+ other -> pprPanic "cgCase: case of primop has strange alts" (pprStgAlts alts)
\end{code}
TODO: Case-of-case of primop can probably be done inline too (but
@@ -229,7 +229,7 @@ eliminate a heap check altogether.
\begin{code}
cgCase (StgApp v []) live_in_whole_case live_in_alts bndr srt
- (StgPrimAlts ty alts deflt)
+ (StgPrimAlts tycon alts deflt)
=
getCAddrMode v `thenFC` \amode ->
@@ -252,7 +252,8 @@ we can reuse/trim the stack slot holding the variable (if it is in one).
\begin{code}
cgCase (StgApp fun args)
- live_in_whole_case live_in_alts bndr srt alts@(StgAlgAlts ty _ _)
+ live_in_whole_case live_in_alts bndr srt alts -- @(StgAlgAlts _ _ _)
+ -- SLPJ: Surely PrimAlts is ok too?
=
getCAddrModeAndInfo fun `thenFC` \ (fun_amode, lf_info) ->
getArgAmodes args `thenFC` \ arg_amodes ->
@@ -265,24 +266,12 @@ cgCase (StgApp fun args)
allocStackTop retPrimRepSize `thenFC` \_ ->
forkEval alts_eob_info nopC (
- deAllocStackTop retPrimRepSize `thenFC` \_ ->
- cgEvalAlts maybe_cc_slot bndr srt alts)
+ deAllocStackTop retPrimRepSize `thenFC` \_ ->
+ cgEvalAlts maybe_cc_slot bndr srt alts)
`thenFC` \ scrut_eob_info ->
- let real_scrut_eob_info =
- if not_con_ty
- then reserveSeqFrame scrut_eob_info
- else scrut_eob_info
- in
-
- setEndOfBlockInfo real_scrut_eob_info (
- tailCallFun fun fun_amode lf_info arg_amodes save_assts
- )
-
- where
- not_con_ty = case (getScrutineeTyCon ty) of
- Just _ -> False
- other -> True
+ setEndOfBlockInfo (maybeReserveSeqFrame alts scrut_eob_info) $
+ tailCallFun fun fun_amode lf_info arg_amodes save_assts
\end{code}
Note about return addresses: we *always* push a return address, even
@@ -311,26 +300,15 @@ cgCase expr live_in_whole_case live_in_alts bndr srt alts
-- generate code for the alts
forkEval alts_eob_info
- (
- nukeDeadBindings live_in_alts `thenC`
+ (nukeDeadBindings live_in_alts `thenC`
allocStackTop retPrimRepSize -- space for retn address
`thenFC` \_ -> nopC
)
(deAllocStackTop retPrimRepSize `thenFC` \_ ->
cgEvalAlts maybe_cc_slot bndr srt alts) `thenFC` \ scrut_eob_info ->
- let real_scrut_eob_info =
- if not_con_ty
- then reserveSeqFrame scrut_eob_info
- else scrut_eob_info
- in
-
- setEndOfBlockInfo real_scrut_eob_info (cgExpr expr)
-
- where
- not_con_ty = case (getScrutineeTyCon (alts_ty alts)) of
- Just _ -> False
- other -> True
+ setEndOfBlockInfo (maybeReserveSeqFrame alts scrut_eob_info) $
+ cgExpr expr
\end{code}
There's a lot of machinery going on behind the scenes to manage the
@@ -368,52 +346,11 @@ don't follow the layout of closures when we're profiling. The CCS
could be anywhere within the record).
\begin{code}
-alts_ty (StgAlgAlts ty _ _) = ty
-alts_ty (StgPrimAlts ty _ _) = ty
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[CgCase-primops]{Primitive applications}
-%* *
-%************************************************************************
-
-Get result amodes for a primitive operation, in the case wher GC can't happen.
-The amodes are returned in canonical order, ready for the prim-op!
-
- Alg case: temporaries named as in the alternatives,
- plus (CTemp u) for the tag (if needed)
- Prim case: (CTemp u)
-
-This is all disgusting, because these amodes must be consistent with those
-invented by CgAlgAlts.
-
-\begin{code}
-getPrimAppResultAmodes
- :: Unique
- -> StgCaseAlts
- -> [CAddrMode]
-
-getPrimAppResultAmodes uniq (StgAlgAlts ty alts some_default)
-
- | isUnboxedTupleTyCon tycon =
- case alts of
- [(con, args, use_mask, rhs)] ->
- [ CTemp (getUnique arg) (idPrimRep arg) | arg <- args ]
- _ -> panic "getPrimAppResultAmodes: case of unboxed tuple has multiple branches"
-
- | otherwise = pprPanic "getPrimAppResultAmodes: case of primop has strange type:" (ppr ty)
-
- where (tycon, _, _) = splitAlgTyConApp ty
-
--- The situation is simpler for primitive results, because there is only
--- one!
-
-getPrimAppResultAmodes uniq (StgPrimAlts ty _ _)
- = [CTemp uniq (typePrimRep ty)]
+-- We need to reserve a seq frame for a polymorphic case
+maybeReserveSeqFrame (StgAlgAlts Nothing _ _) scrut_eob_info = reserveSeqFrame scrut_eob_info
+maybeReserveSeqFrame other scrut_eob_info = scrut_eob_info
\end{code}
-
%************************************************************************
%* *
\subsection[CgCase-alts]{Alternatives}
@@ -442,7 +379,7 @@ cgEvalAlts cc_slot bndr srt alts
case alts of
-- algebraic alts ...
- (StgAlgAlts ty alts deflt) ->
+ StgAlgAlts maybe_tycon alts deflt ->
-- bind the default binder (it covers all the alternatives)
bindNewToReg bndr node mkLFArgument `thenC`
@@ -456,9 +393,8 @@ cgEvalAlts cc_slot bndr srt alts
--
-- which is worse than having the alt code in the switch statement
- let tycon_info = getScrutineeTyCon ty
- is_alg = maybeToBool tycon_info
- Just spec_tycon = tycon_info
+ let is_alg = maybeToBool maybe_tycon
+ Just spec_tycon = maybe_tycon
in
-- deal with the unboxed tuple case
@@ -498,13 +434,13 @@ cgEvalAlts cc_slot bndr srt alts
returnFC (CaseAlts return_vec semi_tagged_stuff)
-- primitive alts...
- (StgPrimAlts ty alts deflt) ->
+ StgPrimAlts tycon alts deflt ->
-- Restore the cost centre
- restoreCurrentCostCentre cc_slot `thenFC` \ cc_restore ->
+ restoreCurrentCostCentre cc_slot `thenFC` \ cc_restore ->
-- Generate the switch
- getAbsC (cgPrimEvalAlts bndr ty alts deflt) `thenFC` \ abs_c ->
+ getAbsC (cgPrimEvalAlts bndr tycon alts deflt) `thenFC` \ abs_c ->
-- Generate the labelled block, starting with restore-cost-centre
getSRTLabel `thenFC` \srt_label ->
@@ -516,38 +452,12 @@ cgEvalAlts cc_slot bndr srt alts
\end{code}
-\begin{code}
-cgInlineAlts :: Id
- -> StgCaseAlts
- -> Code
-\end{code}
-
HWL comment on {\em GrAnSim\/} (adding GRAN_YIELDs for context switch): If
we do an inlining of the case no separate functions for returning are
created, so we don't have to generate a GRAN_YIELD in that case. This info
must be propagated to cgAlgAltRhs (where the GRAN_YIELD macro might be
emitted). Hence, the new Bool arg to cgAlgAltRhs.
-First case: primitive op returns an unboxed tuple.
-
-\begin{code}
-cgInlineAlts bndr (StgAlgAlts ty [alt@(con,args,use_mask,rhs)] StgNoDefault)
- | isUnboxedTupleCon con
- = -- no heap check, no yield, just get in there and do it.
- mapFCs bindNewToTemp args `thenFC` \ _ ->
- cgExpr rhs
-
- | otherwise
- = panic "cgInlineAlts: single alternative, not an unboxed tuple"
-\end{code}
-
-Third (real) case: primitive result type.
-
-\begin{code}
-cgInlineAlts bndr (StgPrimAlts ty alts deflt)
- = cgPrimInlineAlts bndr ty alts deflt
-\end{code}
-
%************************************************************************
%* *
\subsection[CgCase-alg-alts]{Algebraic alternatives}
@@ -743,18 +653,19 @@ the maximum stack depth encountered down any branch.
As usual, no binders in the alternatives are yet bound.
\begin{code}
-cgPrimInlineAlts bndr ty alts deflt
+cgPrimInlineAlts bndr tycon alts deflt
= cgPrimAltsWithDefault bndr NoGC (CTemp uniq kind) alts deflt []
where
uniq = getUnique bndr
- kind = typePrimRep ty
+ kind = tyConPrimRep tycon
-cgPrimEvalAlts bndr ty alts deflt
+cgPrimEvalAlts bndr tycon alts deflt
= cgPrimAltsWithDefault bndr GCMayHappen (CReg reg) alts deflt [reg]
where
- reg = WARN( case kind of { PtrRep -> True; other -> False }, text "cgPrimEE" <+> ppr bndr <+> ppr ty )
+ reg = WARN( case kind of { PtrRep -> True; other -> False },
+ text "cgPrimEE" <+> ppr bndr <+> ppr tycon )
dataReturnConvPrim kind
- kind = typePrimRep ty
+ kind = tyConPrimRep tycon
cgPrimAltsWithDefault bndr gc_flag scrutinee alts deflt regs
= -- first bind the default if necessary
@@ -982,15 +893,3 @@ possibleHeapCheck GCMayHappen is_alg regs tags lbl code
possibleHeapCheck NoGC _ _ tags lbl code
= code
\end{code}
-
-\begin{code}
-getScrutineeTyCon :: Type -> Maybe TyCon
-getScrutineeTyCon ty =
- case splitTyConApp_maybe (repType ty) of
- Nothing -> Nothing
- Just (tc,_) ->
- if isFunTyCon tc then Nothing else -- not interested in funs
- if isPrimTyCon tc then Just tc else -- return primitive tycons
- -- otherwise (algebraic tycons) check the no. of constructors
- Just tc
-\end{code}
diff --git a/ghc/compiler/codeGen/CgExpr.lhs b/ghc/compiler/codeGen/CgExpr.lhs
index 90509f3646..07537fbe26 100644
--- a/ghc/compiler/codeGen/CgExpr.lhs
+++ b/ghc/compiler/codeGen/CgExpr.lhs
@@ -1,7 +1,7 @@
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgExpr.lhs,v 1.37 2000/11/07 13:12:22 simonpj Exp $
+% $Id: CgExpr.lhs,v 1.38 2000/11/15 14:37:08 simonpj Exp $
%
%********************************************************
%* *
@@ -315,7 +315,7 @@ mkRhsClosure bndr cc bi srt
[] -- A thunk
body@(StgCase (StgApp scrutinee [{-no args-}])
_ _ _ _ -- ignore uniq, etc.
- (StgAlgAlts case_ty
+ (StgAlgAlts (Just tycon)
[(con, params, use_mask,
(StgApp selectee [{-no args-}]))]
StgNoDefault))
@@ -332,7 +332,6 @@ mkRhsClosure bndr cc bi srt
Just the_offset = maybe_offset
offset_into_int = the_offset - fixedHdrSize
is_single_constructor = maybeToBool (maybeTyConSingleCon tycon)
- tycon = dataConTyCon con
\end{code}
diff --git a/ghc/compiler/ghci/StgInterp.lhs b/ghc/compiler/ghci/StgInterp.lhs
index f46c491bd8..1bf01dac30 100644
--- a/ghc/compiler/ghci/StgInterp.lhs
+++ b/ghc/compiler/ghci/StgInterp.lhs
@@ -248,9 +248,9 @@ repOfStgExpr stgexpr
other
-> pprPanic "repOfStgExpr" (ppr other)
where
- altRhss (StgAlgAlts ty alts def)
+ altRhss (StgAlgAlts tycon alts def)
= [rhs | (dcon,bndrs,uses,rhs) <- alts] ++ defRhs def
- altRhss (StgPrimAlts ty alts def)
+ altRhss (StgPrimAlts tycon alts def)
= [rhs | (lit,rhs) <- alts] ++ defRhs def
defRhs StgNoDefault
= []
@@ -322,7 +322,7 @@ stg2expr ie stgexpr
(map doPrimAlt alts)
(def2expr def)
- StgCase scrut live liveR bndr srt (StgAlgAlts ty alts def)
+ StgCase scrut live liveR bndr srt (StgAlgAlts tycon alts def)
| repOfStgExpr scrut == RepP
-> mkCaseAlg (repOfStgExpr stgexpr)
bndr (stg2expr ie scrut)
diff --git a/ghc/compiler/main/ErrUtils.lhs b/ghc/compiler/main/ErrUtils.lhs
index b0e0b3a638..8267c933eb 100644
--- a/ghc/compiler/main/ErrUtils.lhs
+++ b/ghc/compiler/main/ErrUtils.lhs
@@ -5,7 +5,7 @@
\begin{code}
module ErrUtils (
- ErrMsg, WarnMsg, Message, Messages, errorsFound,
+ ErrMsg, WarnMsg, Message, Messages, errorsFound, warningsFound,
addShortErrLocLine, addShortWarnLocLine,
addErrLocHdrLine, dontAddErrLoc,
@@ -67,6 +67,9 @@ type Messages = (Bag WarnMsg, Bag ErrMsg)
errorsFound :: Messages -> Bool
errorsFound (warns, errs) = not (isEmptyBag errs)
+warningsFound :: Messages -> Bool
+warningsFound (warns, errs) = not (isEmptyBag warns)
+
printErrorsAndWarnings :: PrintUnqualified -> Messages -> IO ()
-- Don't print any warnings if there are errors
printErrorsAndWarnings unqual (warns, errs)
diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs
index aeae7e1f90..d6ae43cf64 100644
--- a/ghc/compiler/main/HscMain.lhs
+++ b/ghc/compiler/main/HscMain.lhs
@@ -359,6 +359,34 @@ myCoreToStg dflags this_mod tidy_binds
%************************************************************************
%* *
+\subsection{Compiling an expression}
+%* *
+%************************************************************************
+
+hscExpr
+ :: DynFlags
+ -> HomeSymbolTable
+ -> HomeIfaceTable
+ -> PersistentCompilerState -- IN: persistent compiler state
+ -> Module -- Context for compiling
+ -> String -- The expression
+ -> IO HscResult
+
+hscExpr dflags hst hit pcs this_module expr
+ = do { -- Parse it
+ ; maybe_parsed <- myParseExpr dflags expr
+ ; case maybe_parsed of {
+ Nothing -> return (HscFail pcs_ch);
+ Just parsed_expr -> do {
+
+ -- Rename it
+ (new_pcs, maybe_renamed_expr) <- renameExpr dflags hit hst pcs this_module parsed_expr ;
+ case maybe_renamed_expr of {
+ Nothing ->
+
+
+%************************************************************************
+%* *
\subsection{Initial persistent state}
%* *
%************************************************************************
diff --git a/ghc/compiler/profiling/SCCfinal.lhs b/ghc/compiler/profiling/SCCfinal.lhs
index 3cda937626..483854748c 100644
--- a/ghc/compiler/profiling/SCCfinal.lhs
+++ b/ghc/compiler/profiling/SCCfinal.lhs
@@ -192,19 +192,19 @@ stgMassageForProfiling mod_name us stg_binds
do_alts alts `thenMM` \ alts' ->
returnMM (StgCase expr' fv1 fv2 bndr srt alts')
where
- do_alts (StgAlgAlts ty alts def)
+ do_alts (StgAlgAlts tycon alts def)
= mapMM do_alt alts `thenMM` \ alts' ->
do_deflt def `thenMM` \ def' ->
- returnMM (StgAlgAlts ty alts' def')
+ returnMM (StgAlgAlts tycon alts' def')
where
do_alt (id, bs, use_mask, e)
= do_expr e `thenMM` \ e' ->
returnMM (id, bs, use_mask, e')
- do_alts (StgPrimAlts ty alts def)
+ do_alts (StgPrimAlts tycon alts def)
= mapMM do_alt alts `thenMM` \ alts' ->
do_deflt def `thenMM` \ def' ->
- returnMM (StgPrimAlts ty alts' def')
+ returnMM (StgPrimAlts tycon alts' def')
where
do_alt (l,e)
= do_expr e `thenMM` \ e' ->
diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs
index 5affac93d5..7677e22081 100644
--- a/ghc/compiler/rename/Rename.lhs
+++ b/ghc/compiler/rename/Rename.lhs
@@ -4,21 +4,22 @@
\section[Rename]{Renaming and dependency analysis passes}
\begin{code}
-module Rename ( renameModule, closeIfaceDecls, checkOldIface ) where
+module Rename ( renameModule, renameExpr, closeIfaceDecls, checkOldIface ) where
#include "HsVersions.h"
import HsSyn
-import RdrHsSyn ( RdrNameHsModule, RdrNameHsDecl, RdrNameDeprecation,
+import RdrHsSyn ( RdrNameHsModule, RdrNameHsDecl, RdrNameDeprecation, RdrNameHsExpr,
RdrNameTyClDecl, RdrNameRuleDecl, RdrNameInstDecl, RdrNameImportDecl
)
import RnHsSyn ( RenamedHsDecl, RenamedTyClDecl, RenamedRuleDecl, RenamedInstDecl,
- extractHsTyNames,
+ extractHsTyNames, RenamedHsExpr,
instDeclFVs, tyClDeclFVs, ruleDeclFVs
)
import CmdLineOpts ( DynFlags, DynFlag(..) )
import RnMonad
+import RnExpr ( rnExpr )
import RnNames ( getGlobalNames, exportsFromAvail )
import RnSource ( rnSourceDecls, rnTyClDecl, rnIfaceRuleDecl, rnInstDecl )
import RnIfaces ( slurpImpDecls, mkImportInfo,
@@ -34,7 +35,7 @@ import RnEnv ( availsToNameSet, availName,
)
import Module ( Module, ModuleName, WhereFrom(..),
moduleNameUserString, moduleName,
- moduleEnvElts
+ moduleEnvElts, lookupModuleEnv
)
import Name ( Name, NamedThing(..), getSrcLoc,
nameIsLocalOrFrom, nameOccName, nameModule,
@@ -74,9 +75,10 @@ import List ( partition, nub )
+
%*********************************************************
%* *
-\subsection{The main function: rename}
+\subsection{The two main wrappers}
%* *
%*********************************************************
@@ -88,20 +90,63 @@ renameModule :: DynFlags
-> IO (PersistentCompilerState, Maybe (PrintUnqualified, IsExported, ModIface, [RenamedHsDecl]))
-- Nothing => some error occurred in the renamer
-renameModule dflags hit hst old_pcs this_module rdr_module
- = do { showPass dflags "Renamer"
+renameModule dflags hit hst pcs this_module rdr_module
+ = renameSource dflags hit hst pcs this_module get_unqual $
+ rename this_module rdr_module
+ where
+ get_unqual (Just (unqual, _, _, _)) = unqual
+ get_unqual Nothing = alwaysQualify
+\end{code}
- -- Initialise the renamer monad
- ; (new_pcs, msgs, maybe_rn_stuff) <- initRn dflags hit hst old_pcs this_module
- (rename this_module rdr_module)
- ; let print_unqualified = case maybe_rn_stuff of
- Just (unqual, _, _, _) -> unqual
- Nothing -> alwaysQualify
+\begin{code}
+renameExpr :: DynFlags
+ -> HomeIfaceTable -> HomeSymbolTable
+ -> PersistentCompilerState
+ -> Module -> RdrNameHsExpr
+ -> IO (PersistentCompilerState, Maybe RenamedHsExpr)
+
+renameExpr dflags hit hst pcs this_module expr
+ | Just iface <- lookupModuleEnv hit this_module
+ = do { let rdr_env = mi_globals iface
+ ; let get_unqual _ = unQualInScope rdr_env
+
+ ; renameSource dflags hit hst pcs this_module get_unqual $
+ initRnMS rdr_env emptyLocalFixityEnv SourceMode $
+ (rnExpr expr `thenRn` \ (e,_) -> returnRn (Just e))
+ }
+ | otherwise
+ = do { printErrs alwaysQualify (ptext SLIT("renameExpr: Bad module context") <+> ppr this_module)
+ ; return (pcs, Nothing)
+ }
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{The main function: rename}
+%* *
+%*********************************************************
+
+\begin{code}
+renameSource :: DynFlags
+ -> HomeIfaceTable -> HomeSymbolTable
+ -> PersistentCompilerState
+ -> Module
+ -> (Maybe r -> PrintUnqualified)
+ -> RnMG (Maybe r)
+ -> IO (PersistentCompilerState, Maybe r)
+ -- Nothing => some error occurred in the renamer
+
+renameSource dflags hit hst old_pcs this_module get_unqual thing_inside
+ = do { showPass dflags "Renamer"
+
+ -- Initialise the renamer monad
+ ; (new_pcs, msgs, maybe_rn_stuff) <- initRn dflags hit hst old_pcs this_module thing_inside
-- Print errors from renaming
- ; printErrorsAndWarnings print_unqualified msgs ;
+ ; printErrorsAndWarnings (get_unqual maybe_rn_stuff) msgs ;
-- Return results. No harm in updating the PCS
; if errorsFound msgs then
diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs
index c1c7495a40..51319d123a 100644
--- a/ghc/compiler/rename/RnMonad.lhs
+++ b/ghc/compiler/rename/RnMonad.lhs
@@ -31,6 +31,7 @@ import PrelIOBase ( fixIO ) -- Should be in GlaExts
import IOBase ( fixIO )
#endif
import IOExts ( IORef, newIORef, readIORef, writeIORef, unsafePerformIO )
+import IO ( hPutStr, stderr )
import HsSyn
import RdrHsSyn
@@ -46,7 +47,7 @@ import HscTypes ( AvailEnv, lookupType,
RdrAvailInfo )
import BasicTypes ( Version, defaultFixity )
import ErrUtils ( addShortErrLocLine, addShortWarnLocLine,
- pprBagOfErrors, Message, Messages, errorsFound,
+ Message, Messages, errorsFound, warningsFound,
printErrorsAndWarnings
)
import RdrName ( RdrName, dummyRdrVarName, rdrNameModule, rdrNameOcc,
@@ -183,6 +184,9 @@ type LocalFixityEnv = NameEnv RenamedFixitySig
-- can report line-number info when there is a duplicate
-- fixity declaration
+emptyLocalFixityEnv :: LocalFixityEnv
+emptyLocalFixityEnv = emptyNameEnv
+
lookupLocalFixity :: LocalFixityEnv -> Name -> Fixity
lookupLocalFixity env name
= case lookupNameEnv env name of
@@ -365,6 +369,9 @@ initRn dflags hit hst pcs mod do_rn
return (new_pcs, (warns, errs), res)
+initRnMS :: GlobalRdrEnv -> LocalFixityEnv -> RnMode
+ -> RnMS a -> RnM d a
+
initRnMS rn_env fixity_env mode thing_inside rn_down g_down
-- The fixity_env appears in both the rn_fixenv field
-- and in the HIT. See comments with RnHiFiles.lookupFixityRn
@@ -376,11 +383,11 @@ initRnMS rn_env fixity_env mode thing_inside rn_down g_down
initIfaceRnMS :: Module -> RnMS r -> RnM d r
initIfaceRnMS mod thing_inside
- = initRnMS emptyRdrEnv emptyNameEnv InterfaceMode $
+ = initRnMS emptyRdrEnv emptyLocalFixityEnv InterfaceMode $
setModuleRn mod thing_inside
\end{code}
-@renameSourceCode@ is used to rename stuff ``out-of-line'';
+@renameDerivedCode@ is used to rename stuff ``out-of-line'';
that is, not as part of the main renamer.
Sole examples: derived definitions,
which are only generated in the type checker.
@@ -389,52 +396,54 @@ The @NameSupply@ includes a @UniqueSupply@, so if you call it more than
once you must either split it, or install a fresh unique supply.
\begin{code}
-renameSourceCode :: DynFlags
- -> Module
- -> PersistentRenamerState
- -> RnMS r
- -> r
-
-renameSourceCode dflags mod prs m
- = unsafePerformIO (
+renameDerivedCode :: DynFlags
+ -> Module
+ -> PersistentRenamerState
+ -> RnMS r
+ -> r
+
+renameDerivedCode dflags mod prs thing_inside
+ = unsafePerformIO $
-- It's not really unsafe! When renaming source code we
-- only do any I/O if we need to read in a fixity declaration;
-- and that doesn't happen in pragmas etc
- mkSplitUniqSupply 'r' >>= \ new_us ->
- newIORef (new_us, origNames (prsOrig prs),
- origIParam (prsOrig prs)) >>= \ names_var ->
- newIORef (emptyBag,emptyBag) >>= \ errs_var ->
- let
- rn_down = RnDown { rn_dflags = dflags,
- rn_loc = generatedSrcLoc, rn_ns = names_var,
- rn_errs = errs_var,
- rn_mod = mod,
- rn_done = bogus "rn_done", rn_hit = bogus "rn_hit",
- rn_ifaces = bogus "rn_ifaces"
- }
- s_down = SDown { rn_mode = InterfaceMode,
+ do { us <- mkSplitUniqSupply 'r'
+ ; names_var <- newIORef (us, origNames (prsOrig prs),
+ origIParam (prsOrig prs))
+ ; errs_var <- newIORef (emptyBag,emptyBag)
+
+ ; let rn_down = RnDown { rn_dflags = dflags,
+ rn_loc = generatedSrcLoc, rn_ns = names_var,
+ rn_errs = errs_var,
+ rn_mod = mod,
+ rn_done = bogus "rn_done",
+ rn_hit = bogus "rn_hit",
+ rn_ifaces = bogus "rn_ifaces"
+ }
+ ; let s_down = SDown { rn_mode = InterfaceMode,
-- So that we can refer to PrelBase.True etc
- rn_genv = emptyRdrEnv, rn_lenv = emptyRdrEnv,
- rn_fixenv = emptyNameEnv }
- in
- m rn_down s_down >>= \ result ->
-
- readIORef errs_var >>= \ (warns,errs) ->
+ rn_genv = emptyRdrEnv, rn_lenv = emptyRdrEnv,
+ rn_fixenv = emptyLocalFixityEnv }
- (if not (isEmptyBag errs) then
- pprTrace "Urk! renameSourceCode found errors" (display errs)
-#ifdef DEBUG
- else if not (isEmptyBag warns) then
- pprTrace "Note: renameSourceCode found warnings" (display warns)
-#endif
- else
- id) $
+ ; result <- thing_inside rn_down s_down
+ ; messages <- readIORef errs_var
+
+ ; if bad messages then
+ do { hPutStr stderr "Urk! renameDerivedCode found errors or warnings"
+ ; printErrorsAndWarnings alwaysQualify messages
+ }
+ else
+ return()
- return result
- )
+ ; return result
+ }
where
- display errs = pprBagOfErrors errs
+#ifdef DEBUG
+ bad messages = errorsFound messages || warningsFound messages
+#else
+ bad messages = errorsFound messages
+#endif
bogus s = panic ("rnameSourceCode: " ++ s) -- Used for unused record fields
diff --git a/ghc/compiler/simplStg/LambdaLift.lhs b/ghc/compiler/simplStg/LambdaLift.lhs
index 5694475702..4ae2c835af 100644
--- a/ghc/compiler/simplStg/LambdaLift.lhs
+++ b/ghc/compiler/simplStg/LambdaLift.lhs
@@ -161,15 +161,15 @@ liftExpr (StgCase scrut lv1 lv2 bndr srt alts)
lift_alts alts `thenLM` \ (alts', alts_info) ->
returnLM (StgCase scrut' lv1 lv2 bndr srt alts', scrut_info `unionLiftInfo` alts_info)
where
- lift_alts (StgAlgAlts ty alg_alts deflt)
+ lift_alts (StgAlgAlts tycon alg_alts deflt)
= mapAndUnzipLM lift_alg_alt alg_alts `thenLM` \ (alg_alts', alt_infos) ->
lift_deflt deflt `thenLM` \ (deflt', deflt_info) ->
- returnLM (StgAlgAlts ty alg_alts' deflt', foldr unionLiftInfo deflt_info alt_infos)
+ returnLM (StgAlgAlts tycon alg_alts' deflt', foldr unionLiftInfo deflt_info alt_infos)
- lift_alts (StgPrimAlts ty prim_alts deflt)
+ lift_alts (StgPrimAlts tycon prim_alts deflt)
= mapAndUnzipLM lift_prim_alt prim_alts `thenLM` \ (prim_alts', alt_infos) ->
lift_deflt deflt `thenLM` \ (deflt', deflt_info) ->
- returnLM (StgPrimAlts ty prim_alts' deflt', foldr unionLiftInfo deflt_info alt_infos)
+ returnLM (StgPrimAlts tycon prim_alts' deflt', foldr unionLiftInfo deflt_info alt_infos)
lift_alg_alt (con, args, use_mask, rhs)
= liftExpr rhs `thenLM` \ (rhs', rhs_info) ->
diff --git a/ghc/compiler/simplStg/SRT.lhs b/ghc/compiler/simplStg/SRT.lhs
index 54b3a358d6..0b8d20d90d 100644
--- a/ghc/compiler/simplStg/SRT.lhs
+++ b/ghc/compiler/simplStg/SRT.lhs
@@ -349,7 +349,7 @@ Case Alternatives
srtCaseAlts :: UniqFM CafInfo -> (UniqSet Id, UniqFM (UniqSet Id))
-> Int -> StgCaseAlts -> (StgCaseAlts, UniqSet Id, [Id], Int)
-srtCaseAlts rho cont off (StgAlgAlts t alts dflt) =
+srtCaseAlts rho cont off (StgAlgAlts t alts dflt) =
srtAlgAlts rho cont off alts [] emptyUniqSet []
=: \(alts, alts_g, alts_srt, off) ->
srtDefault rho cont off dflt =: \(dflt, dflt_g, dflt_srt, off) ->
diff --git a/ghc/compiler/simplStg/StgVarInfo.lhs b/ghc/compiler/simplStg/StgVarInfo.lhs
index 8c16ec7f0f..88f76bbec0 100644
--- a/ghc/compiler/simplStg/StgVarInfo.lhs
+++ b/ghc/compiler/simplStg/StgVarInfo.lhs
@@ -332,7 +332,7 @@ varsExpr (StgCase scrut _ _ bndr srt alts)
)
)
where
- vars_alts (StgAlgAlts ty alts deflt)
+ vars_alts (StgAlgAlts tycon alts deflt)
= mapAndUnzip3Lne vars_alg_alt alts
`thenLne` \ (alts2, alts_fvs_list, alts_escs_list) ->
let
@@ -341,7 +341,7 @@ varsExpr (StgCase scrut _ _ bndr srt alts)
in
vars_deflt deflt `thenLne` \ (deflt2, deflt_fvs, deflt_escs) ->
returnLne (
- StgAlgAlts ty alts2 deflt2,
+ StgAlgAlts tycon alts2 deflt2,
alts_fvs `unionFVInfo` deflt_fvs,
alts_escs `unionVarSet` deflt_escs
)
@@ -361,7 +361,7 @@ varsExpr (StgCase scrut _ _ bndr srt alts)
-- any of these binders
))
- vars_alts (StgPrimAlts ty alts deflt)
+ vars_alts (StgPrimAlts tycon alts deflt)
= mapAndUnzip3Lne vars_prim_alt alts
`thenLne` \ (alts2, alts_fvs_list, alts_escs_list) ->
let
@@ -370,7 +370,7 @@ varsExpr (StgCase scrut _ _ bndr srt alts)
in
vars_deflt deflt `thenLne` \ (deflt2, deflt_fvs, deflt_escs) ->
returnLne (
- StgPrimAlts ty alts2 deflt2,
+ StgPrimAlts tycon alts2 deflt2,
alts_fvs `unionFVInfo` deflt_fvs,
alts_escs `unionVarSet` deflt_escs
)
diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs
index 4e1ab82995..248453b7e4 100644
--- a/ghc/compiler/stgSyn/CoreToStg.lhs
+++ b/ghc/compiler/stgSyn/CoreToStg.lhs
@@ -25,13 +25,14 @@ import Id ( Id, mkSysLocal, idType, idStrictness, isExportedId,
idFlavour
)
import IdInfo ( StrictnessInfo(..), IdFlavour(..) )
-import DataCon ( dataConWrapId )
+import DataCon ( dataConWrapId, dataConTyCon )
+import TyCon ( isAlgTyCon )
import Demand ( Demand, isStrict, wwLazy )
import Name ( setNameUnique )
import VarEnv
import PrimOp ( PrimOp(..), setCCallUnique )
import Type ( isUnLiftedType, isUnboxedTupleType, Type, splitFunTy_maybe,
- applyTy, repType, seqType,
+ applyTy, repType, seqType, splitTyConApp_maybe,
splitRepFunTys, mkFunTys,
uaUTy, usOnce, usMany, isTyVarTy
)
@@ -585,8 +586,6 @@ coreExprToStgFloat env (Case scrut bndr alts)
default_to_stg env (Just rhs)
= coreExprToStg env rhs `thenUs` \ stg_rhs ->
returnUs (StgBindDefault stg_rhs)
- -- The binder is used for prim cases and not otherwise
- -- (hack for old code gen)
\end{code}
@@ -652,9 +651,27 @@ newLocalIds top_lev env (b:bs)
%************************************************************************
\begin{code}
-mkStgAlgAlts ty alts deflt = seqType ty `seq` StgAlgAlts ty alts deflt
-mkStgPrimAlts ty alts deflt = seqType ty `seq` StgPrimAlts ty alts deflt
-mkStgLam ty bndrs body = seqType ty `seq` StgLam ty bndrs body
+-- There are two things going on in mkStgAlgAlts
+-- a) We pull out the type constructor for the case, from the data
+-- constructor, if there is one. See notes with the StgAlgAlts data type
+-- b) We force the type constructor to avoid space leaks
+
+mkStgAlgAlts ty alts deflt
+ = case alts of
+ -- Get the tycon from the data con
+ (dc, _, _, _):_ -> StgAlgAlts (Just (dataConTyCon dc)) alts deflt
+
+ -- Otherwise just do your best
+ [] -> case splitTyConApp_maybe (repType ty) of
+ Just (tc,_) | isAlgTyCon tc -> StgAlgAlts (Just tc) alts deflt
+ other -> StgAlgAlts Nothing alts deflt
+
+mkStgPrimAlts ty alts deflt
+ = case splitTyConApp_maybe ty of
+ Just (tc,_) -> StgPrimAlts tc alts deflt
+ Nothing -> pprPanic "mkStgAlgAlts" (ppr ty)
+
+mkStgLam ty bndrs body = seqType ty `seq` StgLam ty bndrs body
mkStgApp :: StgEnv -> Id -> [StgArg] -> Type -> UniqSM StgExpr
-- The type is the type of the entire application
@@ -800,7 +817,7 @@ mk_stg_let bndr rhs dem floats body
#endif
| isUnLiftedType bndr_rep_ty -- Use a case/PrimAlts
= ASSERT( not (isUnboxedTupleType bndr_rep_ty) )
- mkStgCase rhs bndr (StgPrimAlts bndr_rep_ty [] (StgBindDefault body)) `thenUs` \ expr' ->
+ mkStgCase rhs bndr (mkStgPrimAlts bndr_rep_ty [] (StgBindDefault body)) `thenUs` \ expr' ->
mkStgBinds floats expr'
| is_whnf
@@ -820,7 +837,7 @@ mk_stg_let bndr rhs dem floats body
| otherwise -- Not WHNF
= if is_strict then
-- Strict let with non-WHNF rhs
- mkStgCase rhs bndr (StgAlgAlts bndr_rep_ty [] (StgBindDefault body)) `thenUs` \ expr' ->
+ mkStgCase rhs bndr (mkStgAlgAlts bndr_rep_ty [] (StgBindDefault body)) `thenUs` \ expr' ->
mkStgBinds floats expr'
else
-- Lazy let with non-WHNF rhs, so keep the floats in the RHS
@@ -895,15 +912,15 @@ way to enforce ordering --SDM.
\begin{code}
-- Discard alernatives in case (par# ..) of
mkStgCase scrut@(StgPrimApp ParOp _ _) bndr
- (StgPrimAlts ty _ deflt@(StgBindDefault _))
- = returnUs (StgCase scrut bOGUS_LVs bOGUS_LVs bndr noSRT (StgPrimAlts ty [] deflt))
+ (StgPrimAlts tycon _ deflt@(StgBindDefault _))
+ = returnUs (StgCase scrut bOGUS_LVs bOGUS_LVs bndr noSRT (StgPrimAlts tycon [] deflt))
mkStgCase (StgPrimApp SeqOp [scrut] _) bndr
(StgPrimAlts _ _ deflt@(StgBindDefault rhs))
= mkStgCase scrut_expr new_bndr new_alts
where
- new_alts | isUnLiftedType scrut_ty = WARN( True, text "mkStgCase" ) StgPrimAlts scrut_ty [] deflt
- | otherwise = StgAlgAlts scrut_ty [] deflt
+ new_alts | isUnLiftedType scrut_ty = WARN( True, text "mkStgCase" ) mkStgPrimAlts scrut_ty [] deflt
+ | otherwise = mkStgAlgAlts scrut_ty [] deflt
scrut_ty = stgArgType scrut
new_bndr = setIdType bndr scrut_ty
-- NB: SeqOp :: forall a. a -> Int#
diff --git a/ghc/compiler/stgSyn/StgLint.lhs b/ghc/compiler/stgSyn/StgLint.lhs
index 59febdd797..bfae2959c1 100644
--- a/ghc/compiler/stgSyn/StgLint.lhs
+++ b/ghc/compiler/stgSyn/StgLint.lhs
@@ -19,7 +19,7 @@ import Literal ( literalType, Literal )
import Maybes ( catMaybes )
import Name ( getSrcLoc )
import ErrUtils ( ErrMsg, Message, addErrLocHdrLine, pprBagOfErrors, dontAddErrLoc )
-import Type ( mkFunTys, splitFunTys, splitAlgTyConApp_maybe,
+import Type ( mkFunTys, splitFunTys, splitAlgTyConApp_maybe, splitTyConApp_maybe,
isUnLiftedType, isTyVarTy, splitForAllTys, Type
)
import TyCon ( TyCon )
@@ -196,8 +196,13 @@ lintStgExpr (StgSCC _ expr) = lintStgExpr expr
lintStgExpr e@(StgCase scrut _ _ bndr _ alts)
= lintStgExpr scrut `thenMaybeL` \ _ ->
- checkTys (idType bndr) scrut_ty (mkDefltMsg bndr) `thenL_`
+ (case alts of
+ StgPrimAlts tc _ _ -> check_bndr tc
+ StgAlgAlts (Just tc) _ _ -> check_bndr tc
+ StgAlgAlts Nothing _ _ -> returnL ()
+ ) `thenL_`
+
(trace (showSDoc (ppr e)) $
-- we only allow case of tail-call or primop.
(case scrut of
@@ -206,12 +211,13 @@ lintStgExpr e@(StgCase scrut _ _ bndr _ alts)
other -> addErrL (mkCaseOfCaseMsg e)) `thenL_`
addInScopeVars [bndr] (lintStgAlts alts scrut_ty)
- )
+ )
where
- scrut_ty = get_ty alts
-
- get_ty (StgAlgAlts ty _ _) = ty
- get_ty (StgPrimAlts ty _ _) = ty
+ scrut_ty = idType bndr
+ bad_bndr = mkDefltMsg bndr
+ check_bndr tc = case splitTyConApp_maybe scrut_ty of
+ Just (bndr_tc, _) -> checkL (tc == bndr_tc) bad_bndr
+ Nothing -> addErrL bad_bndr
\end{code}
\begin{code}
diff --git a/ghc/compiler/stgSyn/StgSyn.lhs b/ghc/compiler/stgSyn/StgSyn.lhs
index 5a40c9d290..c0d94bcc09 100644
--- a/ghc/compiler/stgSyn/StgSyn.lhs
+++ b/ghc/compiler/stgSyn/StgSyn.lhs
@@ -32,7 +32,7 @@ module StgSyn (
SRT(..), noSRT,
pprStgBinding, pprStgBindings, pprStgBindingsWithSRTs,
- getArgPrimRep,
+ getArgPrimRep, pprStgAlts,
isLitLitArg, isDllConApp, isStgTypeArg,
stgArity, stgArgType,
collectFinalStgBinders
@@ -52,6 +52,7 @@ import DataCon ( DataCon, dataConName )
import PrimOp ( PrimOp )
import Outputable
import Type ( Type )
+import TyCon ( TyCon )
import UniqSet ( isEmptyUniqSet, uniqSetToList, UniqSet )
\end{code}
@@ -432,9 +433,33 @@ combineStgBinderInfo (StgBinderInfo arg1 unsat1 std_heap1 upd_heap1 fkap1)
Just like in @CoreSyntax@ (except no type-world stuff).
+* Algebraic cases are done using
+ StgAlgAlts (Just tc) alts deflt
+
+* Polymorphic cases, or case of a function type, are done using
+ StgAlgAlts Nothing [] (StgBindDefault e)
+
+* Primitive cases are done using
+ StgPrimAlts tc alts deflt
+
+We thought of giving polymorphic cases their own constructor,
+but we get a bit more code sharing this way
+
+The type constructor in StgAlgAlts/StgPrimAlts is guaranteed not
+to be abstract; that is, we can see its representation. This is
+important because the code generator uses it to determine return
+conventions etc. But it's not trivial where there's a moduule loop
+involved, because some versions of a type 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}
data GenStgCaseAlts bndr occ
- = StgAlgAlts Type -- so we can find out things about constructor family
+ = StgAlgAlts (Maybe TyCon) -- Just tc => scrutinee type is
+ -- an algebraic data type
+ -- Nothing => scrutinee type is a type
+ -- variable or function type
[(DataCon, -- alts: data constructor,
[bndr], -- constructor's parameters,
[Bool], -- "use mask", same length as
@@ -443,7 +468,8 @@ data GenStgCaseAlts bndr occ
-- used in the ...
GenStgExpr bndr occ)] -- ...right-hand side.
(GenStgCaseDefault bndr occ)
- | StgPrimAlts Type -- so we can find out things about constructor family
+
+ | StgPrimAlts TyCon
[(Literal, -- alts: unboxed literal,
GenStgExpr bndr occ)] -- rhs.
(GenStgCaseDefault bndr occ)
@@ -695,31 +721,32 @@ pprStgExpr (StgCase expr lvs_whole lvs_rhss bndr srt alts)
ptext SLIT("]; rhs lvs: ["), interppSP (uniqSetToList lvs_rhss),
ptext SLIT("]; "),
pprMaybeSRT srt])),
- nest 2 (ppr_alts alts),
+ nest 2 (pprStgAlts alts),
char '}']
where
- ppr_default StgNoDefault = empty
- ppr_default (StgBindDefault expr)
- = hang (hsep [ptext SLIT("DEFAULT"), ptext SLIT("->")]) 4 (ppr expr)
-
- pp_ty (StgAlgAlts ty _ _) = ppr ty
- pp_ty (StgPrimAlts ty _ _) = ppr ty
+ pp_ty (StgAlgAlts maybe_tycon _ _) = ppr maybe_tycon
+ pp_ty (StgPrimAlts tycon _ _) = ppr tycon
- ppr_alts (StgAlgAlts ty alts deflt)
+pprStgAlts (StgAlgAlts _ alts deflt)
= vcat [ vcat (map (ppr_bxd_alt) alts),
- ppr_default deflt ]
+ pprStgDefault deflt ]
where
ppr_bxd_alt (con, params, use_mask, expr)
= hang (hsep [ppr con, interppSP params, ptext SLIT("->")])
4 ((<>) (ppr expr) semi)
- ppr_alts (StgPrimAlts ty alts deflt)
+pprStgAlts (StgPrimAlts _ alts deflt)
= vcat [ vcat (map (ppr_ubxd_alt) alts),
- ppr_default deflt ]
+ pprStgDefault deflt ]
where
ppr_ubxd_alt (lit, expr)
= hang (hsep [ppr lit, ptext SLIT("->")])
4 ((<>) (ppr expr) semi)
+
+pprStgDefault StgNoDefault = empty
+pprStgDefault (StgBindDefault expr) = hang (hsep [ptext SLIT("DEFAULT"), ptext SLIT("->")])
+ 4 (ppr expr)
+
\end{code}
\begin{code}
diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs
index e068f8a04f..259dd94557 100644
--- a/ghc/compiler/typecheck/TcDeriv.lhs
+++ b/ghc/compiler/typecheck/TcDeriv.lhs
@@ -26,8 +26,7 @@ import TcSimplify ( tcSimplifyThetas )
import RnBinds ( rnMethodBinds, rnTopMonoBinds )
import RnEnv ( bindLocatedLocalsRn )
-import RnMonad ( --RnNameSupply,
- renameSourceCode, thenRn, mapRn, returnRn )
+import RnMonad ( renameDerivedCode, thenRn, mapRn, returnRn )
import HscTypes ( DFunId, PersistentRenamerState )
import BasicTypes ( Fixity )
@@ -224,7 +223,7 @@ tcDeriving prs mod inst_env_in get_fixity tycl_decls
-- The only tricky bit is that the extra_binds must scope over the
-- method bindings for the instances.
(rn_method_binds_s, rn_extra_binds)
- = renameSourceCode dflags mod prs (
+ = renameDerivedCode dflags mod prs (
bindLocatedLocalsRn (ptext (SLIT("deriving"))) mbinders $ \ _ ->
rnTopMonoBinds extra_mbinds [] `thenRn` \ (rn_extra_binds, _) ->
mapRn rn_meths method_binds_s `thenRn` \ rn_method_binds_s ->