%
% (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 $
%
%********************************************************
%* *
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
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 ->
`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
\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 ->
\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 ->
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
-- 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
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}
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`
--
-- 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
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 ->
\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}
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
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}
%
% (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 $
%
%********************************************************
%* *
[] -- 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))
Just the_offset = maybe_offset
offset_into_int = the_offset - fixedHdrSize
is_single_constructor = maybeToBool (maybeTyConSingleCon tycon)
- tycon = dataConTyCon con
\end{code}
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
= []
(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)
\begin{code}
module ErrUtils (
- ErrMsg, WarnMsg, Message, Messages, errorsFound,
+ ErrMsg, WarnMsg, Message, Messages, errorsFound, warningsFound,
addShortErrLocLine, addShortWarnLocLine,
addErrLocHdrLine, dontAddErrLoc,
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)
%************************************************************************
%* *
+\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}
%* *
%************************************************************************
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' ->
\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,
)
import Module ( Module, ModuleName, WhereFrom(..),
moduleNameUserString, moduleName,
- moduleEnvElts
+ moduleEnvElts, lookupModuleEnv
)
import Name ( Name, NamedThing(..), getSrcLoc,
nameIsLocalOrFrom, nameOccName, nameModule,
+
%*********************************************************
%* *
-\subsection{The main function: rename}
+\subsection{The two main wrappers}
%* *
%*********************************************************
-> 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
import IOBase ( fixIO )
#endif
import IOExts ( IORef, newIORef, readIORef, writeIORef, unsafePerformIO )
+import IO ( hPutStr, stderr )
import HsSyn
import RdrHsSyn
RdrAvailInfo )
import BasicTypes ( Version, defaultFixity )
import ErrUtils ( addShortErrLocLine, addShortWarnLocLine,
- pprBagOfErrors, Message, Messages, errorsFound,
+ Message, Messages, errorsFound, warningsFound,
printErrorsAndWarnings
)
import RdrName ( RdrName, dummyRdrVarName, rdrNameModule, rdrNameOcc,
-- 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
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
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.
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
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) ->
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) ->
)
)
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
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
)
-- 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
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
)
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
)
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}
%************************************************************************
\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
#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
| 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
\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#
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 )
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
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}
SRT(..), noSRT,
pprStgBinding, pprStgBindings, pprStgBindingsWithSRTs,
- getArgPrimRep,
+ getArgPrimRep, pprStgAlts,
isLitLitArg, isDllConApp, isStgTypeArg,
stgArity, stgArgType,
collectFinalStgBinders
import PrimOp ( PrimOp )
import Outputable
import Type ( Type )
+import TyCon ( TyCon )
import UniqSet ( isEmptyUniqSet, uniqSetToList, UniqSet )
\end{code}
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
-- 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)
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}
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 )
-- 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 ->
projects / ghc-hetmet.git / commitdiff