From: simonpj Date: Wed, 15 Nov 2000 14:37:10 +0000 (+0000) Subject: [project @ 2000-11-15 14:37:08 by simonpj] X-Git-Tag: Approximately_9120_patches~3336 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=8b653a82cdad2eef86395616256304ae4cb18b2b;p=ghc-hetmet.git [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. --- diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs index 07b1db4..1d58b62 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 90509f3..07537fb 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 f46c491..1bf01da 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 b0e0b3a..8267c93 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 aeae7e1..d6ae43c 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 3cda937..4838547 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 5affac9..7677e22 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 c1c7495..51319d1 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 5694475..4ae2c83 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 54b3a35..0b8d20d 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 8c16ec7..88f76bb 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 4e1ab82..248453b 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 59febdd..bfae295 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 5a40c9d..c0d94bc 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 e068f8a..259dd94 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 ->