X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcGenDeriv.lhs;h=4f20887c9545cfe90b1eebeb615a4610cedfb0da;hb=49c84dec1a5612852fb0f484e7dd3be0c99636f4;hp=fb87c891222bf0a824975a3ae3dcbad810710206;hpb=77a8c0dbd5c5ad90fe483cb9ddc2b6ef36d3f4d8;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs index fb87c89..4f20887 100644 --- a/ghc/compiler/typecheck/TcGenDeriv.lhs +++ b/ghc/compiler/typecheck/TcGenDeriv.lhs @@ -28,46 +28,42 @@ module TcGenDeriv ( import HsSyn ( InPat(..), HsExpr(..), MonoBinds(..), Match(..), GRHSs(..), Stmt(..), HsLit(..), - HsBinds(..), StmtCtxt(..), HsType(..), - unguardedRHS, mkSimpleMatch, mkMonoBind, andMonoBindList + HsBinds(..), HsType(..), HsDoContext(..), + unguardedRHS, mkSimpleMatch, mkMonoBind, andMonoBindList, placeHolderType ) -import RdrHsSyn ( mkOpApp, RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat ) -import RdrName ( RdrName, mkSrcUnqual ) -import RnMonad ( FixityEnv, lookupFixity ) +import RdrHsSyn ( mkHsOpApp, RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat ) +import RdrName ( RdrName, mkUnqual ) import BasicTypes ( RecFlag(..), Fixity(..), FixityDirection(..) - , maxPrecedence, defaultFixity + , maxPrecedence , Boxity(..) ) import FieldLabel ( fieldLabelName ) import DataCon ( isNullaryDataCon, dataConTag, dataConOrigArgTys, dataConSourceArity, fIRST_TAG, - DataCon, ConTag, + DataCon, dataConFieldLabels ) import Name ( getOccString, getOccName, getSrcLoc, occNameString, occNameUserString, nameRdrName, varName, - OccName, Name, NamedThing(..), NameSpace, + Name, NamedThing(..), isDataSymOcc, isSymOcc ) +import HscTypes ( FixityEnv, lookupFixity ) import PrelInfo -- Lots of RdrNames -import SrcLoc ( mkGeneratedSrcLoc, SrcLoc ) +import SrcLoc ( generatedSrcLoc, SrcLoc ) import TyCon ( TyCon, isNewTyCon, tyConDataCons, isEnumerationTyCon, maybeTyConSingleCon, tyConFamilySize ) -import Type ( isUnLiftedType, isUnboxedType, Type ) +import TcType ( isUnLiftedType, tcEqType, Type ) import TysPrim ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy, floatPrimTy, doublePrimTy ) -import Util ( mapAccumL, zipEqual, zipWithEqual, - zipWith3Equal, nOfThem, assocDefault ) +import Util ( mapAccumL, zipEqual, zipWithEqual, isSingleton, + zipWith3Equal, nOfThem ) import Panic ( panic, assertPanic ) import Maybes ( maybeToBool ) import Constants import List ( partition, intersperse ) - -#if __GLASGOW_HASKELL__ >= 404 -import GlaExts ( fromInt ) -#endif \end{code} %************************************************************************ @@ -103,7 +99,7 @@ data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ... (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2 \end{verbatim} - Note: if we're comparing unboxed things, e.g., if \tr{a1} and + Note: if we're comparing unlifted things, e.g., if \tr{a1} and \tr{a2} are \tr{Float#}s, then we have to generate \begin{verbatim} case (a1 `eqFloat#` a2) of @@ -185,7 +181,7 @@ gen_Eq_binds tycon else -- calc. and compare the tags [([a_Pat, b_Pat], untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)] - (cmp_tags_Expr eqH_Int_RDR ah_RDR bh_RDR true_Expr false_Expr))] + (genOpApp (HsVar ah_RDR) eqH_Int_RDR (HsVar bh_RDR)))] in mk_FunMonoBind tycon_loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest) `AndMonoBinds` @@ -288,7 +284,7 @@ cmp_eq (O3 a1 b1 c1) (O3 a2 b2 c2) } \end{verbatim} - Again, we must be careful about unboxed comparisons. For example, + Again, we must be careful about unlifted comparisons. For example, if \tr{a1} and \tr{a2} were \tr{Int#}s in the 2nd example above, we'd need to generate: @@ -324,7 +320,7 @@ gen_Ord_binds tycon (if maybeToBool (maybeTyConSingleCon tycon) then -- cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr --- Wierd. Was: case (cmp a b) of { LT -> LT; EQ -> EQ; GT -> GT } +-- Weird. Was: case (cmp a b) of { LT -> LT; EQ -> EQ; GT -> GT } cmp_eq_Expr a_Expr b_Expr else @@ -352,7 +348,7 @@ gen_Ord_binds tycon cmp_eq = mk_FunMonoBind tycon_loc cmp_eq_RDR - (if null nonnullary_cons && (length nullary_cons == 1) then + (if null nonnullary_cons && isSingleton nullary_cons then -- catch this specially to avoid warnings -- about overlapping patterns from the desugarer. let @@ -364,7 +360,7 @@ gen_Ord_binds tycon else map pats_etc nonnullary_cons ++ -- leave out wildcards to silence desugarer. - (if length tycon_data_cons == 1 then + (if isSingleton tycon_data_cons then [] else [([WildPatIn, WildPatIn], default_rhs)])) @@ -393,26 +389,6 @@ gen_Ord_binds tycon -- inexhaustive patterns | otherwise = eqTag_Expr -- Some nullary constructors; -- Tags are equal, no args => return EQ - -------------------------------------------------------------------- - -{- Not necessary: the default decls in PrelBase handle these - -defaulted = foldr1 AndMonoBinds [lt, le, ge, gt, max_, min_] - -lt = mk_easy_FunMonoBind mkGeneratedSrcLoc lt_RDR [a_Pat, b_Pat] [] ( - compare_Case true_Expr false_Expr false_Expr a_Expr b_Expr) -le = mk_easy_FunMonoBind mkGeneratedSrcLoc le_RDR [a_Pat, b_Pat] [] ( - compare_Case true_Expr true_Expr false_Expr a_Expr b_Expr) -ge = mk_easy_FunMonoBind mkGeneratedSrcLoc ge_RDR [a_Pat, b_Pat] [] ( - compare_Case false_Expr true_Expr true_Expr a_Expr b_Expr) -gt = mk_easy_FunMonoBind mkGeneratedSrcLoc gt_RDR [a_Pat, b_Pat] [] ( - compare_Case false_Expr false_Expr true_Expr a_Expr b_Expr) - -max_ = mk_easy_FunMonoBind mkGeneratedSrcLoc max_RDR [a_Pat, b_Pat] [] ( - compare_Case b_Expr a_Expr a_Expr a_Expr b_Expr) -min_ = mk_easy_FunMonoBind mkGeneratedSrcLoc min_RDR [a_Pat, b_Pat] [] ( - compare_Case a_Expr b_Expr b_Expr a_Expr b_Expr) --} \end{code} %************************************************************************ @@ -548,7 +524,7 @@ gen_Bounded_binds tycon = if isEnumerationTyCon tycon then min_bound_enum `AndMonoBinds` max_bound_enum else - ASSERT(length data_cons == 1) + ASSERT(isSingleton data_cons) min_bound_1con `AndMonoBinds` max_bound_1con where data_cons = tyConDataCons tycon @@ -621,7 +597,7 @@ instance ... Ix (Foo ...) where False }}} \end{verbatim} -(modulo suitable case-ification to handle the unboxed tags) +(modulo suitable case-ification to handle the unlifted tags) For a single-constructor type (NB: this includes all tuples), e.g., \begin{verbatim} @@ -667,7 +643,7 @@ gen_Ix_binds tycon in HsCase (genOpApp (HsVar dh_RDR) minusH_RDR (HsVar ah_RDR)) - [mkSimpleMatch [VarPatIn c_RDR] rhs Nothing tycon_loc] + [mkSimpleMatch [VarPatIn c_RDR] rhs placeHolderType tycon_loc] tycon_loc )) ) {-else-} ( @@ -719,7 +695,7 @@ gen_Ix_binds tycon where stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed ++ - [ReturnStmt con_expr] + [ResultStmt con_expr tycon_loc] mk_qual a b c = BindStmt (VarPatIn c) (HsApp (HsVar range_RDR) @@ -774,7 +750,7 @@ gen_Ix_binds tycon \begin{code} gen_Read_binds :: FixityEnv -> TyCon -> RdrNameMonoBinds -gen_Read_binds fixity_env tycon +gen_Read_binds get_fixity tycon = reads_prec `AndMonoBinds` read_list where tycon_loc = getSrcLoc tycon @@ -902,20 +878,20 @@ gen_Read_binds fixity_env tycon then d_Expr else HsVar (last bs_needed)] Boxed - [lp,rp] = getLRPrecs is_infix fixity_env dc_nm + [lp,rp] = getLRPrecs is_infix get_fixity dc_nm quals | is_infix = let (h:t) = field_quals in (h:con_qual:t) | otherwise = con_qual:field_quals - stmts = quals ++ [ReturnStmt result_expr] + stmts = quals ++ [ResultStmt result_expr tycon_loc] {- c.f. Figure 18 in Haskell 1.1 report. -} paren_prec_limit - | not is_infix = fromInt maxPrecedence - | otherwise = getFixity fixity_env dc_nm + | not is_infix = defaultPrecedence + | otherwise = getPrecedence get_fixity dc_nm read_paren_arg -- parens depend on precedence... | nullary_con = false_Expr -- it's optional. @@ -931,7 +907,7 @@ gen_Read_binds fixity_env tycon \begin{code} gen_Show_binds :: FixityEnv -> TyCon -> RdrNameMonoBinds -gen_Show_binds fixity_env tycon +gen_Show_binds get_fixity tycon = shows_prec `AndMonoBinds` show_list where tycon_loc = getSrcLoc tycon @@ -1002,7 +978,7 @@ gen_Show_binds fixity_env tycon mk_showString_app str = HsApp (HsVar showString_RDR) (HsLit (mkHsString str)) - prec_cons = getLRPrecs is_infix fixity_env dc_nm + prec_cons = getLRPrecs is_infix get_fixity dc_nm real_show_thingies | is_infix = @@ -1027,49 +1003,46 @@ gen_Show_binds fixity_env tycon c.f. Figure 16 and 17 in Haskell 1.1 report -} paren_prec_limit - | not is_infix = fromInt maxPrecedence + 1 - | otherwise = getFixity fixity_env dc_nm + 1 + | not is_infix = defaultPrecedence + 1 + | otherwise = getPrecedence get_fixity dc_nm + 1 \end{code} \begin{code} getLRPrecs :: Bool -> FixityEnv -> Name -> [Integer] -getLRPrecs is_infix fixity_env nm = [lp, rp] +getLRPrecs is_infix get_fixity nm = [lp, rp] where {- Figuring out the fixities of the arguments to a constructor, cf. Figures 16-18 in Haskell 1.1 report. -} - (con_left_assoc, con_right_assoc) = isLRAssoc fixity_env nm - paren_con_prec = getFixity fixity_env nm - maxPrec = fromInt maxPrecedence + (con_left_assoc, con_right_assoc) = isLRAssoc get_fixity nm + paren_con_prec = getPrecedence get_fixity nm lp - | not is_infix = maxPrec + 1 + | not is_infix = defaultPrecedence + 1 | con_left_assoc = paren_con_prec | otherwise = paren_con_prec + 1 rp - | not is_infix = maxPrec + 1 + | not is_infix = defaultPrecedence + 1 | con_right_assoc = paren_con_prec | otherwise = paren_con_prec + 1 -getFixity :: FixityEnv -> Name -> Integer -getFixity fixity_env nm = case lookupFixity fixity_env nm of - Fixity x _ -> fromInt x +defaultPrecedence :: Integer +defaultPrecedence = fromIntegral maxPrecedence + +getPrecedence :: FixityEnv -> Name -> Integer +getPrecedence get_fixity nm + = case lookupFixity get_fixity nm of + Fixity x _ -> fromIntegral x isLRAssoc :: FixityEnv -> Name -> (Bool, Bool) -isLRAssoc fixs_assoc nm = - case lookupFixity fixs_assoc nm of +isLRAssoc get_fixity nm = + case lookupFixity get_fixity nm of Fixity _ InfixN -> (False, False) Fixity _ InfixR -> (False, True) Fixity _ InfixL -> (True, False) - -isInfixOccName :: String -> Bool -isInfixOccName str = - case str of - (':':_) -> True - _ -> False \end{code} @@ -1084,7 +1057,7 @@ data Foo ... = ... con2tag_Foo :: Foo ... -> Int# tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int# -maxtag_Foo :: Int -- ditto (NB: not unboxed) +maxtag_Foo :: Int -- ditto (NB: not unlifted) \end{verbatim} The `tags' here start at zero, hence the @fIRST_TAG@ (currently one) @@ -1178,8 +1151,8 @@ mk_FunMonoBind loc fun pats_and_exprs loc mk_match loc pats expr binds - = Match [] (map paren pats) Nothing - (GRHSs (unguardedRHS expr loc) binds Nothing) + = Match (map paren pats) Nothing + (GRHSs (unguardedRHS expr loc) binds placeHolderType) where paren p@(VarPatIn _) = p paren other_p = ParPatIn other_p @@ -1192,10 +1165,6 @@ mk_easy_App f xs = foldl HsApp (HsVar f) (map HsVar xs) ToDo: Better SrcLocs. \begin{code} -compare_Case :: - RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr - -> RdrNameHsExpr -> RdrNameHsExpr - -> RdrNameHsExpr compare_gen_Case :: RdrName -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr @@ -1207,26 +1176,25 @@ careful_compare_Case :: -- checks for primitive types... -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr -compare_Case = compare_gen_Case compare_RDR cmp_eq_Expr a b = HsApp (HsApp (HsVar cmp_eq_RDR) a) b -- Was: compare_gen_Case cmp_eq_RDR compare_gen_Case fun lt eq gt a b = HsCase (HsPar (HsApp (HsApp (HsVar fun) a) b)) {-of-} - [mkSimpleMatch [ConPatIn ltTag_RDR []] lt Nothing mkGeneratedSrcLoc, - mkSimpleMatch [ConPatIn eqTag_RDR []] eq Nothing mkGeneratedSrcLoc, - mkSimpleMatch [ConPatIn gtTag_RDR []] gt Nothing mkGeneratedSrcLoc] - mkGeneratedSrcLoc + [mkSimpleMatch [ConPatIn ltTag_RDR []] lt placeHolderType generatedSrcLoc, + mkSimpleMatch [ConPatIn eqTag_RDR []] eq placeHolderType generatedSrcLoc, + mkSimpleMatch [ConPatIn gtTag_RDR []] gt placeHolderType generatedSrcLoc] + generatedSrcLoc careful_compare_Case ty lt eq gt a b - = if not (isUnboxedType ty) then + | not (isUnLiftedType ty) = compare_gen_Case compare_RDR lt eq gt a b - - else -- we have to do something special for primitive things... + | otherwise = + -- we have to do something special for primitive things... HsIf (genOpApp a relevant_eq_op b) eq - (HsIf (genOpApp a relevant_lt_op b) lt gt mkGeneratedSrcLoc) - mkGeneratedSrcLoc + (HsIf (genOpApp a relevant_lt_op b) lt gt generatedSrcLoc) + generatedSrcLoc where relevant_eq_op = assoc_ty_id eq_op_tbl ty relevant_lt_op = assoc_ty_id lt_op_tbl ty @@ -1235,7 +1203,7 @@ assoc_ty_id tyids ty = if null res then panic "assoc_ty" else head res where - res = [id | (ty',id) <- tyids, ty == ty'] + res = [id | (ty',id) <- tyids, ty `tcEqType` ty'] eq_op_tbl = [(charPrimTy, eqH_Char_RDR) @@ -1265,13 +1233,14 @@ append_Expr a b = genOpApp a append_RDR b ----------------------------------------------------------------------- eq_Expr :: Type -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr -eq_Expr ty a b - = if not (isUnboxedType ty) then - genOpApp a eq_RDR b - else -- we have to do something special for primitive things... - genOpApp a relevant_eq_op b - where - relevant_eq_op = assoc_ty_id eq_op_tbl ty +eq_Expr ty a b = genOpApp a eq_op b + where + eq_op + | not (isUnLiftedType ty) = eq_RDR + | otherwise = + -- we have to do something special for primitive things... + assoc_ty_id eq_op_tbl ty + \end{code} \begin{code} @@ -1279,8 +1248,8 @@ untag_Expr :: TyCon -> [(RdrName, RdrName)] -> RdrNameHsExpr -> RdrNameHsExpr untag_Expr tycon [] expr = expr untag_Expr tycon ((untag_this, put_tag_here) : more) expr = HsCase (HsPar (HsApp (con2tag_Expr tycon) (HsVar untag_this))) {-of-} - [mkSimpleMatch [VarPatIn put_tag_here] (untag_Expr tycon more expr) Nothing mkGeneratedSrcLoc] - mkGeneratedSrcLoc + [mkSimpleMatch [VarPatIn put_tag_here] (untag_Expr tycon more expr) placeHolderType generatedSrcLoc] + generatedSrcLoc cmp_tags_Expr :: RdrName -- Comparison op -> RdrName -> RdrName -- Things to compare @@ -1289,7 +1258,7 @@ cmp_tags_Expr :: RdrName -- Comparison op -> RdrNameHsExpr cmp_tags_Expr op a b true_case false_case - = HsIf (genOpApp (HsVar a) op (HsVar b)) true_case false_case mkGeneratedSrcLoc + = HsIf (genOpApp (HsVar a) op (HsVar b)) true_case false_case generatedSrcLoc enum_from_to_Expr :: RdrNameHsExpr -> RdrNameHsExpr @@ -1350,24 +1319,24 @@ parenify e = HsPar e -- For some reason the renamer doesn't reassociate it right, and I can't -- be bothered to find out why just now. -genOpApp e1 op e2 = mkOpApp e1 op e2 +genOpApp e1 op e2 = mkHsOpApp e1 op e2 \end{code} \begin{code} qual_orig_name n = nameRdrName (getName n) -varUnqual n = mkSrcUnqual varName n - -zz_a_RDR = varUnqual SLIT("_a") -a_RDR = varUnqual SLIT("a") -b_RDR = varUnqual SLIT("b") -c_RDR = varUnqual SLIT("c") -d_RDR = varUnqual SLIT("d") -ah_RDR = varUnqual SLIT("a#") -bh_RDR = varUnqual SLIT("b#") -ch_RDR = varUnqual SLIT("c#") -dh_RDR = varUnqual SLIT("d#") -cmp_eq_RDR = varUnqual SLIT("cmp_eq") -rangeSize_RDR = varUnqual SLIT("rangeSize") +varUnqual n = mkUnqual varName n + +zz_a_RDR = varUnqual FSLIT("_a") +a_RDR = varUnqual FSLIT("a") +b_RDR = varUnqual FSLIT("b") +c_RDR = varUnqual FSLIT("c") +d_RDR = varUnqual FSLIT("d") +ah_RDR = varUnqual FSLIT("a#") +bh_RDR = varUnqual FSLIT("b#") +ch_RDR = varUnqual FSLIT("c#") +dh_RDR = varUnqual FSLIT("d#") +cmp_eq_RDR = varUnqual FSLIT("cmp_eq") +rangeSize_RDR = varUnqual FSLIT("rangeSize") as_RDRs = [ varUnqual (_PK_ ("a"++show i)) | i <- [(1::Int) .. ] ] bs_RDRs = [ varUnqual (_PK_ ("b"++show i)) | i <- [(1::Int) .. ] ]