%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgExpr.lhs,v 1.38 2000/11/15 14:37:08 simonpj Exp $
+% $Id: CgExpr.lhs,v 1.39 2000/11/15 17:07:34 simonpj Exp $
%
%********************************************************
%* *
import PrimRep ( PrimRep(..), isFollowableRep )
import TyCon ( maybeTyConSingleCon,
isUnboxedTupleTyCon, isEnumerationTyCon )
-import Type ( Type, typePrimRep, splitTyConApp_maybe, repType )
+import Type ( Type, typePrimRep, splitTyConApp, tyConAppTyCon, repType )
import Maybes ( maybeToBool )
import ListSetOps ( assocMaybe )
import Unique ( mkBuiltinUnique )
--
-- That won't work.
--
- (Just (tycon,_)) = splitTyConApp_maybe res_ty
+ tycon = tyConAppTyCon res_ty
cgExpr x@(StgPrimApp op args res_ty)
allocate some temporaries for the return values.
-}
let
- (tc,ty_args) = case splitTyConApp_maybe (repType res_ty) of
- Nothing -> pprPanic "primRetUnboxedTuple" (ppr res_ty)
- Just pr -> pr
- prim_reps = map typePrimRep ty_args
- temp_uniqs = map mkBuiltinUnique [ n_args .. n_args + length ty_args - 1]
- temp_amodes = zipWith CTemp temp_uniqs prim_reps
+ (tc,ty_args) = splitTyConApp (repType res_ty)
+ prim_reps = map typePrimRep ty_args
+ temp_uniqs = map mkBuiltinUnique [ n_args .. n_args + length ty_args - 1]
+ temp_amodes = zipWith CTemp temp_uniqs prim_reps
in
returnUnboxedTuple temp_amodes (absC (COpStmt temp_amodes op arg_temps []))
\end{code}
import SrcLoc ( SrcLoc, noSrcLoc )
import Type ( Type, tyVarsOfType,
splitFunTy_maybe, mkTyVarTy,
- splitForAllTy_maybe, splitTyConApp_maybe,
+ splitForAllTy_maybe, splitTyConApp_maybe, splitTyConApp,
isUnLiftedType, typeKind,
isUnboxedTupleType,
hasMoreBoxityInfo
-- Scrutinee type must be a tycon applicn; checked by caller
-- This code is remarkably compact considering what it does!
-- NB: args must be in scope here so that the lintCoreArgs line works.
- case splitTyConApp_maybe scrut_ty of { Just (tycon, tycon_arg_tys) ->
+ case splitTyConApp scrut_ty of { (tycon, tycon_arg_tys) ->
lintTyApps (dataConRepType con) tycon_arg_tys `thenL` \ con_type ->
lintCoreArgs con_type (map mk_arg args) `thenL` \ con_result_ty ->
checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty)
tc_binds = all_binds,
tc_rules = rules,
tc_fords = fo_decls})
- = do
- showPass dflags "Desugar"
- us <- mkSplitUniqSupply 'd'
+ = do { showPass dflags "Desugar"
+ ; us <- mkSplitUniqSupply 'd'
-- Do desugaring
- let (result, ds_warns) =
- initDs dflags us (hst,pcs,global_val_env) mod_name
- (dsProgram mod_name all_binds rules fo_decls)
- (ds_binds, ds_rules, _, _, _) = result
+ ; let (result, ds_warns) = initDs dflags us (hst,pcs,global_val_env) mod_name
+ (dsProgram mod_name all_binds rules fo_decls)
+ (ds_binds, ds_rules, _, _, _) = result
-- Display any warnings
- doIfSet (not (isEmptyBag ds_warns))
- (printErrs unqual (pprBagOfWarnings ds_warns))
+ ; doIfSet (not (isEmptyBag ds_warns))
+ (printErrs unqual (pprBagOfWarnings ds_warns))
-- Lint result if necessary
- let do_dump_ds = dopt Opt_D_dump_ds dflags
- endPass dflags "Desugar" do_dump_ds ds_binds
+ ; let do_dump_ds = dopt Opt_D_dump_ds dflags
+ ; endPass dflags "Desugar" do_dump_ds ds_binds
-- Dump output
- doIfSet do_dump_ds (printDump (ppr_ds_rules ds_rules))
+ ; doIfSet do_dump_ds (printDump (ppr_ds_rules ds_rules))
- return result
+ ; return result
+ }
+
+-- deSugarExpr dflags unqual hst tc_expr
+-- = do {
dsProgram mod_name all_binds rules fo_decls
= dsMonoBinds auto_scc all_binds [] `thenDs` \ core_prs ->
NamedThing(..),
)
import Type ( repType,
- splitTyConApp_maybe, splitFunTys, splitForAllTys,
+ splitTyConApp_maybe, tyConAppTyCon, splitFunTys, splitForAllTys,
Type, mkFunTys, mkForAllTys, mkTyConApp,
mkFunTy, splitAppTy, applyTy, funResultTy
)
showStgType t = text "Hs" <> text (showFFIType t)
showFFIType :: Type -> String
-showFFIType t = getOccString (getName tc)
- where
- tc = case splitTyConApp_maybe (repType t) of
- Just (tc,_) -> tc
- Nothing -> pprPanic "showFFIType" (ppr t)
+showFFIType t = getOccString (getName (tyConAppTyCon t))
\end{code}
-- Rename it
(new_pcs, maybe_renamed_expr) <- renameExpr dflags hit hst pcs this_module parsed_expr ;
- case maybe_renamed_expr of {
- Nothing ->
+ ; case maybe_renamed_expr of {
+ Nothing -> FAIL
+ Just renamed_expr ->
+
+ -- Typecheck it
+ maybe_tc_expr <- typecheckExpr dflags pcs hst unqual renamed_expr
+ ; case maybe_tc_expr of
+ Nothing -> FAIL
+ Just typechecked_expr ->
+
+
%************************************************************************
import TyCon ( tyConDataConsIfAvailable, isEnumerationTyCon, isNewTyCon )
import DataCon ( dataConTag, dataConTyCon, dataConId, fIRST_TAG )
import CoreUtils ( exprIsValue, cheapEqExpr, exprIsConApp_maybe )
-import Type ( splitTyConApp_maybe )
+import Type ( tyConAppTyCon )
import OccName ( occNameUserString)
import PrelNames ( unpackCStringFoldrName, unpackCStringFoldrIdKey, hasKey )
import Name ( Name )
Just (SLIT("TagToEnum"), Var (dataConId dc))
where
correct_tag dc = (dataConTag dc - fIRST_TAG) == tag
- tag = fromInteger i
- (Just (tycon,_)) = splitTyConApp_maybe ty
+ tag = fromInteger i
+ tycon = tyConAppTyCon ty
tagToEnumRule other = Nothing
\end{code}
import TyCon ( TyCon, tyConArity )
import Type ( Type, mkForAllTys, mkFunTy, mkFunTys, mkTyVarTys,
mkTyConApp, typePrimRep,
- splitFunTy_maybe, splitAlgTyConApp_maybe, splitTyConApp_maybe,
+ splitFunTy_maybe, splitAlgTyConApp_maybe, splitTyConApp,
mkUTy, usOnce, usMany
)
import Unique ( Unique, mkPrimOpIdUnique )
Nothing -> pprPanic "primOpUsg:inFun" (ppr op <+> ppr ty)
inUB op fs ty
- = case splitTyConApp_maybe ty of
- Just (tc,tys) -> ASSERT( tc == tupleTyCon Unboxed (length fs) )
- mkTupleTy Unboxed (length fs) (zipWithEqual "primOpUsg"
- ($) fs tys)
- Nothing -> pprPanic "primOpUsg:inUB" (ppr op <+> ppr ty)
+ = case splitTyConApp ty of
+ (tc,tys) -> ASSERT( tc == tupleTyCon Unboxed (length fs) )
+ mkTupleTy Unboxed (length fs) (zipWithEqual "primOpUsg" ($) fs tys)
\end{code}
\begin{code}
import Id ( Id, idType )
import CoreUtils ( hashExpr, cheapEqExpr, exprIsBig, mkAltExpr )
import DataCon ( isUnboxedTupleCon )
-import Type ( splitTyConApp_maybe )
+import Type ( tyConAppArgs )
import Subst ( InScopeSet, uniqAway, emptyInScopeSet,
extendInScopeSet, elemInScopeSet )
import CoreSyn
other -> (bndr', extendCSEnv env bndr' scrut') -- See "yet another wrinkle"
-- map: scrut' -> bndr'
- arg_tys = case splitTyConApp_maybe (idType bndr) of
- Just (_, arg_tys) -> arg_tys
- other -> pprPanic "cseAlts" (ppr bndr)
+ arg_tys = tyConAppArgs (idType bndr)
cse_alt (DataAlt con, args, rhs)
| not (null args || isUnboxedTupleCon con)
import Demand ( isStrict )
import SimplMonad
import Type ( Type, mkForAllTys, seqType, repType,
- splitTyConApp_maybe, mkTyVarTys, splitFunTys,
+ splitTyConApp_maybe, tyConAppArgs, mkTyVarTys, splitFunTys,
isDictTy, isDataType, isUnLiftedType,
splitRepFunTys
)
(mkConApp con (map Type arg_tys ++ map varToCoreExpr args))
identity_alt other = False
- arg_tys = case splitTyConApp_maybe (idType case_bndr) of
- Just (tycon, arg_tys) -> arg_tys
+ arg_tys = tyConAppArgs (idType case_bndr)
\end{code}
The catch-all case
import Rules ( lookupRule )
import CostCentre ( currentCCS )
import Type ( mkTyVarTys, isUnLiftedType, seqType,
- mkFunTy, splitTyConApp_maybe,
+ mkFunTy, splitTyConApp_maybe, tyConAppArgs,
funResultTy
)
import Subst ( mkSubst, substTy,
simplAlts zap_occ_info scrut_cons case_bndr' alts cont'
= mapSmpl simpl_alt alts
where
- inst_tys' = case splitTyConApp_maybe (idType case_bndr') of
- Just (tycon, inst_tys) -> inst_tys
+ inst_tys' = tyConAppArgs (idType case_bndr')
-- handled_cons is all the constructors that are dealt
-- with, either by being impossible, or by there being an alternative
import VarEnv
import PrimOp ( PrimOp(..), setCCallUnique )
import Type ( isUnLiftedType, isUnboxedTupleType, Type, splitFunTy_maybe,
- applyTy, repType, seqType, splitTyConApp_maybe,
+ applyTy, repType, seqType, splitTyConApp_maybe, splitTyConApp,
splitRepFunTys, mkFunTys,
uaUTy, usOnce, usMany, isTyVarTy
)
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)
+ = case splitTyConApp ty of
+ (tc,_) -> StgPrimAlts tc alts deflt
mkStgLam ty bndrs body = seqType ty `seq` StgLam ty bndrs body
import Type ( Type,
tyVarsOfTypes, splitDFunTy,
splitForAllTys, splitRhoTy,
- getDFunTyKey, splitTyConApp_maybe
+ getDFunTyKey, tyConAppTyCon
)
import DataCon ( DataCon )
import TyCon ( TyCon )
simpleInstInfoTyCon :: InstInfo -> TyCon
-- Gets the type constructor for a simple instance declaration,
-- i.e. one of the form instance (...) => C (T a b c) where ...
-simpleInstInfoTyCon inst
- = case splitTyConApp_maybe (simpleInstInfoTy inst) of
- Just (tycon, _) -> tycon
+simpleInstInfoTyCon inst = tyConAppTyCon (simpleInstInfoTy inst)
\end{code}
\section[TcExpr]{Typecheck an expression}
\begin{code}
-module TcExpr ( tcApp, tcExpr, tcPolyExpr, tcId ) where
+module TcExpr ( tcApp, tcExpr, tcMonoExpr, tcPolyExpr, tcId ) where
#include "HsVersions.h"
\begin{code}
module TcModule (
- typecheckModule,
- TcResults(..)
+ typecheckModule, typecheckExpr, TcResults(..)
) where
#include "HsVersions.h"
import CmdLineOpts ( DynFlag(..), DynFlags, opt_PprStyle_Debug )
import HsSyn ( HsBinds(..), MonoBinds(..), HsDecl(..) )
import HsTypes ( toHsType )
-import RnHsSyn ( RenamedHsDecl )
-import TcHsSyn ( TypecheckedMonoBinds,
+import RnHsSyn ( RenamedHsDecl, RenamedHsExpr )
+import TcHsSyn ( TypecheckedMonoBinds, TypecheckedHsExpr,
TypecheckedForeignDecl, TypecheckedRuleDecl,
- zonkTopBinds, zonkForeignExports, zonkRules
+ zonkTopBinds, zonkForeignExports, zonkRules, mkHsLet
)
+
import TcMonad
+import TcType ( newTyVarTy )
import Inst ( plusLIE )
import TcBinds ( tcTopBinds )
import TcClassDcl ( tcClassDecls2, mkImplicitClassBinds )
import TcDefaults ( tcDefaults )
+import TcExpr ( tcMonoExpr )
import TcEnv ( TcEnv, InstInfo(iDFunId), tcExtendGlobalValEnv,
tcEnvTyCons, tcEnvClasses, isLocalThing,
tcSetEnv, tcSetInstEnv, initTcEnv, getTcGEnv
import TcTyDecls ( mkImplicitDataBinds )
import CoreUnfold ( unfoldingTemplate )
-import Type ( funResultTy, splitForAllTys )
+import Type ( funResultTy, splitForAllTys, openTypeKind )
import Bag ( isEmptyBag )
import ErrUtils ( printErrorsAndWarnings, dumpIfSet_dyn, showPass )
import Id ( idType, idUnfolding )
-> IO (Maybe TcResults)
typecheckModule dflags this_mod pcs hst mod_iface unqual decls
+ = do { maybe_tc_result <- typecheck dflags pcs hst unqual $
+ tcModule pcs hst get_fixity this_mod decls
+ ; printTcDump dflags maybe_tc_result
+ ; return maybe_tc_result }
+ where
+ fixity_env = mi_fixities mod_iface
+
+ get_fixity :: Name -> Maybe Fixity
+ get_fixity nm = lookupNameEnv fixity_env nm
+
+---------------
+typecheckExpr :: DynFlags
+ -> PersistentCompilerState
+ -> HomeSymbolTable
+ -> PrintUnqualified -- For error printing
+ -> RenamedHsExpr
+ -> IO (Maybe TypecheckedHsExpr)
+
+typecheckExpr dflags pcs hst unqual expr
+ = typecheck dflags pcs hst unqual $
+ newTyVarTy openTypeKind `thenTc` \ ty ->
+ tcMonoExpr expr ty `thenTc` \ (expr', lie) ->
+ tcSimplifyTop lie `thenTc` \ binds ->
+ returnTc (mkHsLet binds expr')
+
+---------------
+typecheck :: DynFlags
+ -> PersistentCompilerState
+ -> HomeSymbolTable
+ -> PrintUnqualified -- For error printing
+ -> TcM r
+ -> IO (Maybe r)
+
+typecheck dflags pcs hst unqual thing_inside
= do { showPass dflags "Typechecker";
; env <- initTcEnv hst (pcs_PTE pcs)
- ; (maybe_tc_result, (warns,errs)) <- initTc dflags env (tcModule pcs hst get_fixity this_mod decls)
+ ; (maybe_tc_result, (warns,errs)) <- initTc dflags env thing_inside
; printErrorsAndWarnings unqual (errs,warns)
- ; printTcDump dflags maybe_tc_result
; if isEmptyBag errs then
return maybe_tc_result
else
return Nothing
}
- where
- fixity_env = mi_fixities mod_iface
-
- get_fixity :: Name -> Maybe Fixity
- get_fixity nm = lookupNameEnv fixity_env nm
\end{code}
The internal monster:
import VarEnv ( TyVarSubstEnv )
import Maybes ( MaybeErr(..), returnMaB, failMaB, thenMaB, maybeToBool )
import Name ( getSrcLoc )
-import Type ( Type, splitTyConApp_maybe,
+import Type ( Type, tyConAppTyCon,
splitSigmaTy, splitDFunTy, tyVarsOfTypes
)
import PprType ( )
= (clas, tycon)
where
(_,_,clas,[ty]) = splitDFunTy (idType dfun)
- tycon = case splitTyConApp_maybe ty of
- Just (tycon,_) -> tycon
+ tycon = tyConAppTyCon ty
\end{code}
%************************************************************************
mkFunTy, mkFunTys, splitFunTy, splitFunTy_maybe, splitFunTys, splitFunTysN,
funResultTy, funArgTy, zipFunTys,
- mkTyConApp, mkTyConTy, splitTyConApp_maybe,
+ mkTyConApp, mkTyConTy,
+ tyConAppTyCon, tyConAppArgs,
+ splitTyConApp_maybe, splitTyConApp,
splitAlgTyConApp_maybe, splitAlgTyConApp,
mkUTy, splitUTy, splitUTy_maybe,
-- mean a distinct type, but all other type-constructor applications
-- including functions are returned as Just ..
+tyConAppTyCon :: Type -> TyCon
+tyConAppTyCon ty = case splitTyConApp_maybe ty of
+ Just (tc,_) -> tc
+ Nothing -> pprPanic "tyConAppTyCon" (pprType ty)
+
+tyConAppArgs :: Type -> [Type]
+tyConAppArgs ty = case splitTyConApp_maybe ty of
+ Just (_,args) -> args
+ Nothing -> pprPanic "tyConAppArgs" (pprType ty)
+
+splitTyConApp :: Type -> (TyCon, [Type])
+splitTyConApp ty = case splitTyConApp_maybe ty of
+ Just stuff -> stuff
+ Nothing -> pprPanic "splitTyConApp" (pprType ty)
+
splitTyConApp_maybe :: Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
splitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [unUTy arg,unUTy res])
import Rules ( RuleBase )
import TypeRep ( Type(..), TyNote(..) ) -- friend
import Type ( applyTy, applyTys,
- splitFunTy_maybe, splitFunTys, splitTyConApp_maybe,
+ splitFunTy_maybe, splitFunTys, splitTyConApp,
mkFunTy, mkForAllTy )
import TyCon ( tyConArgVrcs_maybe, isFunTyCon )
import Literal ( Literal(..), literalType )
(e2,y2u,h2,f2) <- usgInfCE ve e1
let h3 = usgEqTy y2u y1u -- **! why not subty?
(u2,y2) = splitUsgTy y2u
- (tc,y2s) = expectJust "usgInfCE:Case" $ splitTyConApp_maybe y2
+ (tc,y2s) = splitTyConApp y2
(cs,v1ss,es) = unzip3 alts
v2ss = map (map (\ v -> setVarType v (mkUsgTy u2 (annotManyN (varType v)))))
v1ss
projects / ghc-hetmet.git / commitdiff