X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcGenDeriv.lhs;h=4627e2214f0e2c44a42bcc77ec70e1382d3bd1b9;hb=24f3ffdaa0ffd164616969080c3e6400f04980dd;hp=d67ffc0aba0850c6c62df141c77b5bcfbe2a9897;hpb=25f84fa7e4b84c3db5ba745a7881c009b778e0b1;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs index d67ffc0..4627e22 100644 --- a/compiler/typecheck/TcGenDeriv.lhs +++ b/compiler/typecheck/TcGenDeriv.lhs @@ -11,13 +11,6 @@ This module is nominally ``subordinate'' to @TcDeriv@, which is the This is where we do all the grimy bindings' generation. \begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - module TcGenDeriv ( DerivAuxBind(..), DerivAuxBinds, isDupAux, @@ -72,10 +65,10 @@ data DerivAuxBind -- Please add these auxiliary top-level bindings | GenMaxTag TyCon -- ...and maxTag isDupAux :: DerivAuxBind -> DerivAuxBind -> Bool -isDupAux (GenCon2Tag tc1) (GenCon2Tag tc2) = tc1==tc2 -isDupAux (GenTag2Con tc1) (GenTag2Con tc2) = tc1==tc2 -isDupAux (GenMaxTag tc1) (GenMaxTag tc2) = tc1==tc2 -isDupAux b1 b2 = False +isDupAux (GenCon2Tag tc1) (GenCon2Tag tc2) = tc1 == tc2 +isDupAux (GenTag2Con tc1) (GenTag2Con tc2) = tc1 == tc2 +isDupAux (GenMaxTag tc1) (GenMaxTag tc2) = tc1 == tc2 +isDupAux _ _ = False \end{code} @@ -305,6 +298,10 @@ JJQC-30-Nov-1997 gen_Ord_binds :: TyCon -> (LHsBinds RdrName, DerivAuxBinds) gen_Ord_binds tycon + | Just (con, prim_tc) <- primWrapperType_maybe tycon + = gen_PrimOrd_binds con prim_tc + + | otherwise = (unitBag compare, aux_binds) -- `AndMonoBinds` compare -- The default declaration in PrelBase handles this @@ -375,7 +372,58 @@ gen_Ord_binds tycon in careful_compare_Case tycon ty eq_expr (nlHsVar a) (nlHsVar b) nested_compare_expr _ _ _ = panic "nested_compare_expr" -- Args always equal length +\end{code} +Note [Comparision of primitive types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The general plan does not work well for data types like + data T = MkT Int# deriving( Ord ) +The general plan defines the 'compare' method, gets (<) etc from it. But +that means we get silly code like: + instance Ord T where + (>) (I# x) (I# y) = case <# x y of + True -> False + False -> case ==# x y of + True -> False + False -> True +We would prefer to use the (>#) primop. See also Trac #2130 + + +\begin{code} +gen_PrimOrd_binds :: DataCon -> TyCon -> (LHsBinds RdrName, DerivAuxBinds) +-- See Note [Comparison of primitive types] +gen_PrimOrd_binds data_con prim_tc + = (listToBag [mk_op lt_RDR lt_op, mk_op le_RDR le_op, + mk_op ge_RDR ge_op, mk_op gt_RDR gt_op], []) + where + mk_op op_RDR op = mk_FunBind (getSrcSpan data_con) op_RDR + [([apat, bpat], genOpApp a_Expr (primOpRdrName op) b_Expr)] + con_RDR = getRdrName data_con + apat = nlConVarPat con_RDR [a_RDR] + bpat = nlConVarPat con_RDR [b_RDR] + + (lt_op, le_op, ge_op, gt_op) + | prim_tc == charPrimTyCon = (CharLtOp, CharLeOp, CharGeOp, CharGtOp) + | prim_tc == intPrimTyCon = (IntLtOp, IntLeOp, IntGeOp, IntGtOp) + | prim_tc == wordPrimTyCon = (WordLtOp, WordLeOp, WordGeOp, WordGtOp) + | prim_tc == addrPrimTyCon = (AddrLtOp, AddrLeOp, AddrGeOp, AddrGtOp) + | prim_tc == floatPrimTyCon = (FloatLtOp, FloatLeOp, FloatGeOp, FloatGtOp) + | prim_tc == doublePrimTyCon = (DoubleLtOp, DoubleLeOp, DoubleGeOp, DoubleGtOp) + | otherwise = pprPanic "Unexpected primitive tycon" (ppr prim_tc) + + +primWrapperType_maybe :: TyCon -> Maybe (DataCon, TyCon) +-- True of data types that are wrappers around prmitive types +-- data T = MkT Word# +-- For these we want to generate all the (<), (<=) etc operations individually +primWrapperType_maybe tc + | [con] <- tyConDataCons tc + , [ty] <- dataConOrigArgTys con + , Just (prim_tc, []) <- tcSplitTyConApp_maybe ty + , isPrimTyCon prim_tc + = Just (con, prim_tc) + | otherwise + = Nothing \end{code} %************************************************************************ @@ -675,7 +723,11 @@ gen_Ix_binds tycon = mk_easy_FunBind tycon_loc unsafeIndex_RDR [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed, con_pat cs_needed] - (mk_index (zip3 as_needed bs_needed cs_needed)) + -- We need to reverse the order we consider the components in + -- so that + -- range (l,u) !! index (l,u) i == i -- when i is in range + -- (from http://haskell.org/onlinereport/ix.html) holds. + (mk_index (reverse $ zip3 as_needed bs_needed cs_needed)) where -- index (l1,u1) i1 + rangeSize (l1,u1) * (index (l2,u2) i2 + ...) mk_index [] = nlHsIntLit 0 @@ -986,9 +1038,10 @@ wrapOpBackquotes s | isSym s = s | otherwise = '`' : s ++ "`" isSym :: String -> Bool -isSym "" = False -isSym (c:cs) = startsVarSym c || startsConSym c +isSym "" = False +isSym (c : _) = startsVarSym c || startsConSym c +mk_showString_app :: String -> LHsExpr RdrName mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str)) \end{code} @@ -1006,7 +1059,10 @@ appPrecedence = fromIntegral maxPrecedence + 1 getPrecedence :: FixityEnv -> Name -> Integer getPrecedence get_fixity nm = case lookupFixity get_fixity nm of - Fixity x _ -> fromIntegral x + Fixity x _assoc -> fromIntegral x + -- NB: the Report says that associativity is not taken + -- into account for either Read or Show; hence we + -- ignore associativity here \end{code} @@ -1086,7 +1142,7 @@ gen_Data_binds :: FixityEnv -> TyCon -> (LHsBinds RdrName, -- The method bindings DerivAuxBinds) -- Auxiliary bindings -gen_Data_binds fix_env tycon +gen_Data_binds _ tycon = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind], -- Auxiliary definitions: the data type and constructors DerivAuxBind datatype_bind : map mk_con_bind data_cons) @@ -1175,15 +1231,17 @@ gen_Data_binds fix_env tycon fixity | is_infix = infix_RDR | otherwise = prefix_RDR -gfoldl_RDR = varQual_RDR gENERICS FSLIT("gfoldl") -gunfold_RDR = varQual_RDR gENERICS FSLIT("gunfold") -toConstr_RDR = varQual_RDR gENERICS FSLIT("toConstr") -dataTypeOf_RDR = varQual_RDR gENERICS FSLIT("dataTypeOf") -mkConstr_RDR = varQual_RDR gENERICS FSLIT("mkConstr") -mkDataType_RDR = varQual_RDR gENERICS FSLIT("mkDataType") -conIndex_RDR = varQual_RDR gENERICS FSLIT("constrIndex") -prefix_RDR = dataQual_RDR gENERICS FSLIT("Prefix") -infix_RDR = dataQual_RDR gENERICS FSLIT("Infix") +gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR, + mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR :: RdrName +gfoldl_RDR = varQual_RDR gENERICS (fsLit "gfoldl") +gunfold_RDR = varQual_RDR gENERICS (fsLit "gunfold") +toConstr_RDR = varQual_RDR gENERICS (fsLit "toConstr") +dataTypeOf_RDR = varQual_RDR gENERICS (fsLit "dataTypeOf") +mkConstr_RDR = varQual_RDR gENERICS (fsLit "mkConstr") +mkDataType_RDR = varQual_RDR gENERICS (fsLit "mkDataType") +conIndex_RDR = varQual_RDR gENERICS (fsLit "constrIndex") +prefix_RDR = dataQual_RDR gENERICS (fsLit "Prefix") +infix_RDR = dataQual_RDR gENERICS (fsLit "Infix") \end{code} %************************************************************************ @@ -1282,6 +1340,7 @@ careful_compare_Case :: -- checks for primitive types... -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName +cmp_eq_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName cmp_eq_Expr a b = nlHsApp (nlHsApp (nlHsVar cmp_eq_RDR) a) b -- Was: compare_gen_Case cmp_eq_RDR @@ -1297,9 +1356,10 @@ careful_compare_Case tycon ty eq a b | not (isUnLiftedType ty) = compare_gen_Case eq a b | otherwise -- We have to do something special for primitive things... - = nlHsIf (genOpApp a relevant_eq_op b) - eq - (nlHsIf (genOpApp a relevant_lt_op b) ltTag_Expr gtTag_Expr) + = nlHsIf (genOpApp a relevant_lt_op b) -- Test (<) first, not (==), becuase the latter + ltTag_Expr -- is true less often, so putting it first would + -- mean more tests (dynamically) + (nlHsIf (genOpApp a relevant_eq_op b) eq gtTag_Expr) where relevant_eq_op = primOpRdrName (assoc_ty_id "Ord" tycon eq_op_tbl ty) relevant_lt_op = primOpRdrName (assoc_ty_id "Ord" tycon lt_op_tbl ty) @@ -1321,7 +1381,7 @@ assoc_ty_id :: String -- The class involved -> [(Type,a)] -- The table -> Type -- The type -> a -- The result of the lookup -assoc_ty_id cls_str tycon tbl ty +assoc_ty_id cls_str _ tbl ty | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+> text "for primitive type" <+> ppr ty) | otherwise = head res @@ -1348,6 +1408,7 @@ lt_op_tbl = ,(doublePrimTy, DoubleLtOp) ] +box_con_tbl :: [(Type, RdrName)] box_con_tbl = [(charPrimTy, getRdrName charDataCon) ,(intPrimTy, getRdrName intDataCon) @@ -1374,7 +1435,7 @@ eq_Expr tycon ty a b = genOpApp a eq_op b \begin{code} untag_Expr :: TyCon -> [( RdrName, RdrName)] -> LHsExpr RdrName -> LHsExpr RdrName -untag_Expr tycon [] expr = expr +untag_Expr _ [] expr = expr untag_Expr tycon ((untag_this, put_tag_here) : more) expr = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-} [mkSimpleHsAlt (nlVarPat put_tag_here) (untag_Expr tycon more expr)] @@ -1413,15 +1474,18 @@ nested_compose_Expr (e:es) -- impossible_Expr is used in case RHSs that should never happen. -- We generate these to keep the desugarer from complaining that they *might* happen! +impossible_Expr :: LHsExpr RdrName impossible_Expr = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString "Urk! in TcGenDeriv")) -- illegal_Expr is used when signalling error conditions in the RHS of a derived -- method. It is currently only used by Enum.{succ,pred} +illegal_Expr :: String -> String -> String -> LHsExpr RdrName illegal_Expr meth tp msg = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg))) -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you -- to include the value of a_RDR in the error string. +illegal_toEnum_tag :: String -> RdrName -> LHsExpr RdrName illegal_toEnum_tag tp maxtag = nlHsApp (nlHsVar error_RDR) (nlHsApp (nlHsApp (nlHsVar append_RDR) @@ -1439,31 +1503,38 @@ illegal_toEnum_tag tp maxtag = (nlHsVar maxtag)) (nlHsLit (mkHsString ")")))))) +parenify :: LHsExpr RdrName -> LHsExpr RdrName parenify e@(L _ (HsVar _)) = e parenify e = mkHsPar e -- genOpApp wraps brackets round the operator application, so that the -- renamer won't subsequently try to re-associate it. +genOpApp :: LHsExpr RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2) \end{code} \begin{code} -a_RDR = mkVarUnqual FSLIT("a") -b_RDR = mkVarUnqual FSLIT("b") -c_RDR = mkVarUnqual FSLIT("c") -d_RDR = mkVarUnqual FSLIT("d") -k_RDR = mkVarUnqual FSLIT("k") -z_RDR = mkVarUnqual FSLIT("z") -ah_RDR = mkVarUnqual FSLIT("a#") -bh_RDR = mkVarUnqual FSLIT("b#") -ch_RDR = mkVarUnqual FSLIT("c#") -dh_RDR = mkVarUnqual FSLIT("d#") -cmp_eq_RDR = mkVarUnqual FSLIT("cmp_eq") - +a_RDR, b_RDR, c_RDR, d_RDR, k_RDR, z_RDR, ah_RDR, bh_RDR, ch_RDR, dh_RDR, + cmp_eq_RDR :: RdrName +a_RDR = mkVarUnqual (fsLit "a") +b_RDR = mkVarUnqual (fsLit "b") +c_RDR = mkVarUnqual (fsLit "c") +d_RDR = mkVarUnqual (fsLit "d") +k_RDR = mkVarUnqual (fsLit "k") +z_RDR = mkVarUnqual (fsLit "z") +ah_RDR = mkVarUnqual (fsLit "a#") +bh_RDR = mkVarUnqual (fsLit "b#") +ch_RDR = mkVarUnqual (fsLit "c#") +dh_RDR = mkVarUnqual (fsLit "d#") +cmp_eq_RDR = mkVarUnqual (fsLit "cmp_eq") + +as_RDRs, bs_RDRs, cs_RDRs :: [RdrName] as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ] bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ] cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ] +a_Expr, b_Expr, c_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr, + false_Expr, true_Expr :: LHsExpr RdrName a_Expr = nlHsVar a_RDR b_Expr = nlHsVar b_RDR c_Expr = nlHsVar c_RDR @@ -1473,6 +1544,7 @@ gtTag_Expr = nlHsVar gtTag_RDR false_Expr = nlHsVar false_RDR true_Expr = nlHsVar true_RDR +a_Pat, b_Pat, c_Pat, d_Pat, k_Pat, z_Pat :: LPat RdrName a_Pat = nlVarPat a_RDR b_Pat = nlVarPat b_RDR c_Pat = nlVarPat c_RDR @@ -1480,27 +1552,25 @@ d_Pat = nlVarPat d_RDR k_Pat = nlVarPat k_RDR z_Pat = nlVarPat z_RDR -con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName +con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName -- Generates Orig s RdrName, for the binding positions -con2tag_RDR tycon = mk_tc_deriv_name tycon "con2tag_" -tag2con_RDR tycon = mk_tc_deriv_name tycon "tag2con_" -maxtag_RDR tycon = mk_tc_deriv_name tycon "maxtag_" +con2tag_RDR tycon = mk_tc_deriv_name tycon mkCon2TagOcc +tag2con_RDR tycon = mk_tc_deriv_name tycon mkTag2ConOcc +maxtag_RDR tycon = mk_tc_deriv_name tycon mkMaxTagOcc -mk_tc_deriv_name tycon str - = mkDerivedRdrName tc_name mk_occ - where - tc_name = tyConName tycon - mk_occ tc_occ = mkVarOccFS (mkFastString new_str) - where - new_str = str ++ occNameString tc_occ ++ "#" +mk_tc_deriv_name :: TyCon -> (OccName -> OccName) -> RdrName +mk_tc_deriv_name tycon fun = mkDerivedRdrName (tyConName tycon) fun \end{code} s RdrName for PrimOps. Can't be done in PrelNames, because PrimOp imports PrelNames, so PrelNames can't import PrimOp. \begin{code} +primOpRdrName :: PrimOp -> RdrName primOpRdrName op = getRdrName (primOpId op) +minusInt_RDR, eqInt_RDR, ltInt_RDR, geInt_RDR, leInt_RDR, + tagToEnum_RDR :: RdrName minusInt_RDR = primOpRdrName IntSubOp eqInt_RDR = primOpRdrName IntEqOp ltInt_RDR = primOpRdrName IntLtOp @@ -1508,5 +1578,6 @@ geInt_RDR = primOpRdrName IntGeOp leInt_RDR = primOpRdrName IntLeOp tagToEnum_RDR = primOpRdrName TagToEnumOp +error_RDR :: RdrName error_RDR = getRdrName eRROR_ID \end{code}