diff options
Diffstat (limited to 'compiler/coreSyn')
| -rw-r--r-- | compiler/coreSyn/CoreArity.lhs | 3 | ||||
| -rw-r--r-- | compiler/coreSyn/CoreFVs.lhs | 2 | ||||
| -rw-r--r-- | compiler/coreSyn/CoreLint.lhs | 10 | ||||
| -rw-r--r-- | compiler/coreSyn/CorePrep.lhs | 3 | ||||
| -rw-r--r-- | compiler/coreSyn/CoreSubst.lhs | 3 | ||||
| -rw-r--r-- | compiler/coreSyn/CoreSyn.lhs | 5 | ||||
| -rw-r--r-- | compiler/coreSyn/CoreTidy.lhs | 118 | ||||
| -rw-r--r-- | compiler/coreSyn/CoreUnfold.lhs | 3 | ||||
| -rw-r--r-- | compiler/coreSyn/CoreUtils.lhs | 39 | ||||
| -rw-r--r-- | compiler/coreSyn/ExternalCore.lhs | 118 | ||||
| -rw-r--r-- | compiler/coreSyn/MkCore.lhs | 7 | ||||
| -rw-r--r-- | compiler/coreSyn/MkExternalCore.lhs | 360 | ||||
| -rw-r--r-- | compiler/coreSyn/PprCore.lhs | 2 | ||||
| -rw-r--r-- | compiler/coreSyn/PprExternalCore.lhs | 260 | ||||
| -rw-r--r-- | compiler/coreSyn/TrieMap.lhs | 4 |
15 files changed, 125 insertions, 812 deletions
diff --git a/compiler/coreSyn/CoreArity.lhs b/compiler/coreSyn/CoreArity.lhs index ca7216fe29..26669b6d32 100644 --- a/compiler/coreSyn/CoreArity.lhs +++ b/compiler/coreSyn/CoreArity.lhs @@ -6,7 +6,8 @@ Arity and eta expansion \begin{code} -{-# OPTIONS -fno-warn-tabs #-} +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and -- detab the module (please do the detabbing in a separate patch). See diff --git a/compiler/coreSyn/CoreFVs.lhs b/compiler/coreSyn/CoreFVs.lhs index 636c049c42..4011191d75 100644 --- a/compiler/coreSyn/CoreFVs.lhs +++ b/compiler/coreSyn/CoreFVs.lhs @@ -5,6 +5,8 @@ Taken quite directly from the Peyton Jones/Lester paper. \begin{code} +{-# LANGUAGE CPP #-} + -- | A module concerned with finding the free variables of an expression. module CoreFVs ( -- * Free variables of expressions and binding groups diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs index b5c79855f2..a5868108d9 100644 --- a/compiler/coreSyn/CoreLint.lhs +++ b/compiler/coreSyn/CoreLint.lhs @@ -7,12 +7,7 @@ A ``lint'' pass to check for Core correctness \begin{code} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - +{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fprof-auto #-} module CoreLint ( lintCoreBindings, lintUnfolding, lintExpr ) where @@ -856,6 +851,9 @@ lintCoercion co@(TyConAppCo r tc cos) ; checkRole co2 r r2 ; return (rk, mkFunTy s1 s2, mkFunTy t1 t2, r) } + | Just {} <- synTyConDefn_maybe tc + = failWithL (ptext (sLit "Synonym in TyConAppCo:") <+> ppr co) + | otherwise = do { (ks,ss,ts,rs) <- mapAndUnzip4M lintCoercion cos ; rk <- lint_co_app co (tyConKind tc) (ss `zip` ks) diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs index 5e0cd6599d..c754aae4e7 100644 --- a/compiler/coreSyn/CorePrep.lhs +++ b/compiler/coreSyn/CorePrep.lhs @@ -5,7 +5,7 @@ Core pass to saturate constructors and PrimOps \begin{code} -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BangPatterns, CPP #-} module CorePrep ( corePrepPgm, corePrepExpr, cvtLitInteger, @@ -196,6 +196,7 @@ corePrepTopBinds initialCorePrepEnv binds mkDataConWorkers :: [TyCon] -> [CoreBind] -- See Note [Data constructor workers] +-- c.f. Note [Injecting implicit bindings] in TidyPgm mkDataConWorkers data_tycons = [ NonRec id (Var id) -- The ice is thin here, but it works | tycon <- data_tycons, -- CorePrep will eta-expand it diff --git a/compiler/coreSyn/CoreSubst.lhs b/compiler/coreSyn/CoreSubst.lhs index ef601a2a09..f3215094df 100644 --- a/compiler/coreSyn/CoreSubst.lhs +++ b/compiler/coreSyn/CoreSubst.lhs @@ -6,7 +6,8 @@ Utility functions on @Core@ syntax \begin{code} -{-# OPTIONS -fno-warn-tabs #-} +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and -- detab the module (please do the detabbing in a separate patch). See diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs index defd669a78..b36cb6d8a6 100644 --- a/compiler/coreSyn/CoreSyn.lhs +++ b/compiler/coreSyn/CoreSyn.lhs @@ -4,9 +4,8 @@ % \begin{code} -{-# LANGUAGE DeriveDataTypeable, DeriveFunctor #-} - -{-# OPTIONS -fno-warn-tabs #-} +{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and -- detab the module (please do the detabbing in a separate patch). See diff --git a/compiler/coreSyn/CoreTidy.lhs b/compiler/coreSyn/CoreTidy.lhs index 8c0ae4a65a..4754aa5afb 100644 --- a/compiler/coreSyn/CoreTidy.lhs +++ b/compiler/coreSyn/CoreTidy.lhs @@ -7,7 +7,8 @@ This module contains "tidying" code for *nested* expressions, bindings, rules. The code for *top-level* bindings is in TidyPgm. \begin{code} -{-# OPTIONS -fno-warn-tabs #-} +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and -- detab the module (please do the detabbing in a separate patch). See @@ -33,7 +34,6 @@ import Name hiding (tidyNameOcc) import SrcLoc import Maybes import Data.List -import Outputable \end{code} @@ -141,18 +141,48 @@ tidyBndr env var tidyBndrs :: TidyEnv -> [Var] -> (TidyEnv, [Var]) tidyBndrs env vars = mapAccumL tidyBndr env vars +-- Non-top-level variables +tidyIdBndr :: TidyEnv -> Id -> (TidyEnv, Id) +tidyIdBndr env@(tidy_env, var_env) id + = -- Do this pattern match strictly, otherwise we end up holding on to + -- stuff in the OccName. + case tidyOccName tidy_env (getOccName id) of { (tidy_env', occ') -> + let + -- Give the Id a fresh print-name, *and* rename its type + -- The SrcLoc isn't important now, + -- though we could extract it from the Id + -- + ty' = tidyType env (idType id) + name' = mkInternalName (idUnique id) occ' noSrcSpan + id' = mkLocalIdWithInfo name' ty' new_info + var_env' = extendVarEnv var_env id id' + + -- Note [Tidy IdInfo] + new_info = vanillaIdInfo `setOccInfo` occInfo old_info + `setUnfoldingInfo` new_unf + old_info = idInfo id + old_unf = unfoldingInfo old_info + new_unf | isEvaldUnfolding old_unf = evaldUnfolding + | otherwise = noUnfolding + -- See Note [Preserve evaluatedness] + in + ((tidy_env', var_env'), id') + } + tidyLetBndr :: TidyEnv -- Knot-tied version for unfoldings -> TidyEnv -- The one to extend -> (Id, CoreExpr) -> (TidyEnv, Var) -- Used for local (non-top-level) let(rec)s -tidyLetBndr rec_tidy_env env (id,rhs) - = ((tidy_occ_env,new_var_env), final_id) - where - ((tidy_occ_env,var_env), new_id) = tidyIdBndr env id - new_var_env = extendVarEnv var_env id final_id - -- Override the env we get back from tidyId with the - -- new IdInfo so it gets propagated to the usage sites. +-- Just like tidyIdBndr above, but with more IdInfo +tidyLetBndr rec_tidy_env env@(tidy_env, var_env) (id,rhs) + = case tidyOccName tidy_env (getOccName id) of { (tidy_env', occ') -> + let + ty' = tidyType env (idType id) + name' = mkInternalName (idUnique id) occ' noSrcSpan + id' = mkLocalIdWithInfo name' ty' new_info + var_env' = extendVarEnv var_env id id' + -- Note [Tidy IdInfo] -- We need to keep around any interesting strictness and -- demand info because later on we may need to use it when -- converting to A-normal form. @@ -161,48 +191,27 @@ tidyLetBndr rec_tidy_env env (id,rhs) -- into case (g x) of z -> f z by CorePrep, but only if f still -- has its strictness info. -- - -- Similarly for the demand info - on a let binder, this tells + -- Similarly for the demand info - on a let binder, this tells -- CorePrep to turn the let into a case. -- -- Similarly arity info for eta expansion in CorePrep - -- - -- Set inline-prag info so that we preseve it across + -- + -- Set inline-prag info so that we preseve it across -- separate compilation boundaries - final_id = new_id `setIdInfo` new_info - idinfo = idInfo id - new_info = idInfo new_id - `setArityInfo` exprArity rhs - `setStrictnessInfo` strictnessInfo idinfo - `setDemandInfo` demandInfo idinfo - `setInlinePragInfo` inlinePragInfo idinfo - `setUnfoldingInfo` new_unf - - new_unf | isStableUnfolding unf = tidyUnfolding rec_tidy_env unf (panic "tidy_unf") - | otherwise = noUnfolding - unf = unfoldingInfo idinfo - --- Non-top-level variables -tidyIdBndr :: TidyEnv -> Id -> (TidyEnv, Id) -tidyIdBndr env@(tidy_env, var_env) id - = -- Do this pattern match strictly, otherwise we end up holding on to - -- stuff in the OccName. - case tidyOccName tidy_env (getOccName id) of { (tidy_env', occ') -> - let - -- Give the Id a fresh print-name, *and* rename its type - -- The SrcLoc isn't important now, - -- though we could extract it from the Id - -- - ty' = tidyType env (idType id) - name' = mkInternalName (idUnique id) occ' noSrcSpan - id' = mkLocalIdWithInfo name' ty' new_info - var_env' = extendVarEnv var_env id id' - - -- Note [Tidy IdInfo] - new_info = vanillaIdInfo `setOccInfo` occInfo old_info old_info = idInfo id + new_info = vanillaIdInfo + `setOccInfo` occInfo old_info + `setArityInfo` exprArity rhs + `setStrictnessInfo` strictnessInfo old_info + `setDemandInfo` demandInfo old_info + `setInlinePragInfo` inlinePragInfo old_info + `setUnfoldingInfo` new_unf + + new_unf | isStableUnfolding old_unf = tidyUnfolding rec_tidy_env old_unf old_unf + | otherwise = noUnfolding + old_unf = unfoldingInfo old_info in - ((tidy_env', var_env'), id') - } + ((tidy_env', var_env'), id') } ------------ Unfolding -------------- tidyUnfolding :: TidyEnv -> Unfolding -> Unfolding -> Unfolding @@ -234,9 +243,26 @@ two reasons: the benefit of that occurrence analysis when we use the rule or or inline the function. In particular, it's vital not to lose loop-breaker info, else we get an infinite inlining loop - + Note that tidyLetBndr puts more IdInfo back. +Note [Preserve evaluatedness] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T = MkT !Bool + ....(case v of MkT y -> + let z# = case y of + True -> 1# + False -> 2# + in ...) + +The z# binding is ok because the RHS is ok-for-speculation, +but Lint will complain unless it can *see* that. So we +preserve the evaluated-ness on 'y' in tidyBndr. + +(Another alternative would be to tidy unboxed lets into cases, +but that seems more indirect and surprising.) + \begin{code} (=:) :: a -> (a -> b) -> b diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs index 3a2c237602..fa9259a005 100644 --- a/compiler/coreSyn/CoreUnfold.lhs +++ b/compiler/coreSyn/CoreUnfold.lhs @@ -15,7 +15,8 @@ literal''). In the corner of a @CoreUnfolding@ unfolding, you will find, unsurprisingly, a Core expression. \begin{code} -{-# OPTIONS -fno-warn-tabs #-} +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and -- detab the module (please do the detabbing in a separate patch). See diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs index ea2e17fb04..3bf07febf3 100644 --- a/compiler/coreSyn/CoreUtils.lhs +++ b/compiler/coreSyn/CoreUtils.lhs @@ -6,6 +6,8 @@ Utility functions on @Core@ syntax \begin{code} +{-# LANGUAGE CPP #-} + -- | Commonly useful utilites for manipulating the Core language module CoreUtils ( -- * Constructing expressions @@ -215,7 +217,7 @@ mkCast expr co -- if to_ty `eqType` from_ty -- then expr -- else - WARN(not (from_ty `eqType` exprType expr), text "Trying to coerce" <+> text "(" <> ppr expr $$ text "::" <+> ppr (exprType expr) <> text ")" $$ ppr co $$ pprEqPred (coercionKind co)) + WARN(not (from_ty `eqType` exprType expr), text "Trying to coerce" <+> text "(" <> ppr expr $$ text "::" <+> ppr (exprType expr) <> text ")" $$ ppr co $$ ppr (coercionType co)) (Cast expr co) \end{code} @@ -1222,7 +1224,7 @@ dataConInstPat :: [FastString] -- A long enough list of FSs to use for -> [Unique] -- An equally long list of uniques, at least one for each binder -> DataCon -> [Type] -- Types to instantiate the universally quantified tyvars - -> ([TyVar], [Id]) -- Return instantiated variables + -> ([TyVar], [Id]) -- Return instantiated variables -- dataConInstPat arg_fun fss us con inst_tys returns a triple -- (ex_tvs, arg_ids), -- @@ -1250,14 +1252,14 @@ dataConInstPat :: [FastString] -- A long enough list of FSs to use for -- -- where the double-primed variables are created with the FastStrings and -- Uniques given as fss and us -dataConInstPat fss uniqs con inst_tys +dataConInstPat fss uniqs con inst_tys = ASSERT( univ_tvs `equalLength` inst_tys ) (ex_bndrs, arg_ids) - where + where univ_tvs = dataConUnivTyVars con ex_tvs = dataConExTyVars con arg_tys = dataConRepArgTys con - + arg_strs = dataConRepStrictness con -- 1-1 with arg_tys n_ex = length ex_tvs -- split the Uniques and FastStrings @@ -1268,7 +1270,7 @@ dataConInstPat fss uniqs con inst_tys univ_subst = zipOpenTvSubst univ_tvs inst_tys -- Make existential type variables, applyingn and extending the substitution - (full_subst, ex_bndrs) = mapAccumL mk_ex_var univ_subst + (full_subst, ex_bndrs) = mapAccumL mk_ex_var univ_subst (zip3 ex_tvs ex_fss ex_uniqs) mk_ex_var :: TvSubst -> (TyVar, FastString, Unique) -> (TvSubst, TyVar) @@ -1280,11 +1282,30 @@ dataConInstPat fss uniqs con inst_tys kind = Type.substTy subst (tyVarKind tv) -- Make value vars, instantiating types - arg_ids = zipWith3 mk_id_var id_uniqs id_fss arg_tys - mk_id_var uniq fs ty = mkUserLocal (mkVarOccFS fs) uniq - (Type.substTy full_subst ty) noSrcSpan + arg_ids = zipWith4 mk_id_var id_uniqs id_fss arg_tys arg_strs + mk_id_var uniq fs ty str + = mkLocalIdWithInfo name (Type.substTy full_subst ty) info + where + name = mkInternalName uniq (mkVarOccFS fs) noSrcSpan + info | isMarkedStrict str = vanillaIdInfo `setUnfoldingInfo` evaldUnfolding + | otherwise = vanillaIdInfo + -- See Note [Mark evaluated arguments] \end{code} +Note [Mark evaluated arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When pattern matching on a constructor with strict fields, the binder +can have an 'evaldUnfolding'. Moreover, it *should* have one, so that +when loading an interface file unfolding like: + data T = MkT !Int + f x = case x of { MkT y -> let v::Int# = case y of I# n -> n+1 + in ... } +we don't want Lint to complain. The 'y' is evaluated, so the +case in the RHS of the binding for 'v' is fine. But only if we +*know* that 'y' is evaluated. + +c.f. add_evals in Simplify.simplAlt + %************************************************************************ %* * Equality diff --git a/compiler/coreSyn/ExternalCore.lhs b/compiler/coreSyn/ExternalCore.lhs deleted file mode 100644 index ecc24b1155..0000000000 --- a/compiler/coreSyn/ExternalCore.lhs +++ /dev/null @@ -1,118 +0,0 @@ -% -% (c) The University of Glasgow 2001-2006 -% -\begin{code} -module ExternalCore where - -import Data.Word - -data Module - = Module Mname [Tdef] [Vdefg] - -data Tdef - = Data (Qual Tcon) [Tbind] [Cdef] - | Newtype (Qual Tcon) (Qual Tcon) [Tbind] Ty - -data Cdef - = Constr (Qual Dcon) [Tbind] [Ty] - | GadtConstr (Qual Dcon) Ty - -data Vdefg - = Rec [Vdef] - | Nonrec Vdef - --- Top-level bindings are qualified, so that the printer doesn't have to pass --- around the module name. -type Vdef = (Bool,Qual Var,Ty,Exp) - -data Exp - = Var (Qual Var) - | Dcon (Qual Dcon) - | Lit Lit - | App Exp Exp - | Appt Exp Ty - | Lam Bind Exp - | Let Vdefg Exp - | Case Exp Vbind Ty [Alt] {- non-empty list -} - | Cast Exp Coercion - | Tick String Exp {- XXX probably wrong -} - | External String String Ty {- target name, convention, and type -} - | DynExternal String Ty {- convention and type (incl. Addr# of target as first arg) -} - | Label String - -data Bind - = Vb Vbind - | Tb Tbind - -data Alt - = Acon (Qual Dcon) [Tbind] [Vbind] Exp - | Alit Lit Exp - | Adefault Exp - -type Vbind = (Var,Ty) -type Tbind = (Tvar,Kind) - -data Ty - = Tvar Tvar - | Tcon (Qual Tcon) - | Tapp Ty Ty - | Tforall Tbind Ty - -data Coercion --- We distinguish primitive coercions because External Core treats --- them specially, so we have to print them out with special syntax. - = ReflCoercion Role Ty - | SymCoercion Coercion - | TransCoercion Coercion Coercion - | TyConAppCoercion Role (Qual Tcon) [Coercion] - | AppCoercion Coercion Coercion - | ForAllCoercion Tbind Coercion - | CoVarCoercion Var - | UnivCoercion Role Ty Ty - | InstCoercion Coercion Ty - | NthCoercion Int Coercion - | AxiomCoercion (Qual Tcon) Int [Coercion] - | LRCoercion LeftOrRight Coercion - | SubCoercion Coercion - -data Role = Nominal | Representational | Phantom - -data LeftOrRight = CLeft | CRight - -data Kind - = Klifted - | Kunlifted - | Kunboxed - | Kopen - | Karrow Kind Kind - -data Lit - = Lint Integer Ty - | Lrational Rational Ty - | Lchar Char Ty - | Lstring [Word8] Ty - - -type Mname = Id -type Var = Id -type Tvar = Id -type Tcon = Id -type Dcon = Id - -type Qual t = (Mname,t) - -type Id = String - -primMname :: Mname --- For truly horrible reasons, this must be z-encoded. --- With any hope, the z-encoding will die soon. -primMname = "ghczmprim:GHCziPrim" - -tcArrow :: Qual Tcon -tcArrow = (primMname, "(->)") - -\end{code} - - - - diff --git a/compiler/coreSyn/MkCore.lhs b/compiler/coreSyn/MkCore.lhs index f71b4b4ff6..5213f92bac 100644 --- a/compiler/coreSyn/MkCore.lhs +++ b/compiler/coreSyn/MkCore.lhs @@ -1,5 +1,6 @@ \begin{code} -{-# OPTIONS -fno-warn-tabs #-} +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and -- detab the module (please do the detabbing in a separate patch). See @@ -303,9 +304,9 @@ mkStringExprFS str mkEqBox :: Coercion -> CoreExpr mkEqBox co = ASSERT2( typeKind ty2 `eqKind` k, ppr co $$ ppr ty1 $$ ppr ty2 $$ ppr (typeKind ty1) $$ ppr (typeKind ty2) ) Var (dataConWorkId datacon) `mkTyApps` [k, ty1, ty2] `App` Coercion co - where Pair ty1 ty2 = coercionKind co + where (Pair ty1 ty2, role) = coercionKindRole co k = typeKind ty1 - datacon = case coercionRole co of + datacon = case role of Nominal -> eqBoxDataCon Representational -> coercibleDataCon Phantom -> pprPanic "mkEqBox does not support boxing phantom coercions" diff --git a/compiler/coreSyn/MkExternalCore.lhs b/compiler/coreSyn/MkExternalCore.lhs deleted file mode 100644 index 6a6f0551ed..0000000000 --- a/compiler/coreSyn/MkExternalCore.lhs +++ /dev/null @@ -1,360 +0,0 @@ - -% (c) The University of Glasgow 2001-2006 -% -\begin{code} -module MkExternalCore ( - emitExternalCore -) where - -#include "HsVersions.h" - -import qualified ExternalCore as C -import Module -import CoreSyn -import HscTypes -import TyCon -import CoAxiom --- import Class -import TypeRep -import Type -import Kind -import PprExternalCore () -- Instances -import DataCon -import Coercion -import Var -import IdInfo -import Literal -import Name -import Outputable -import Encoding -import ForeignCall -import DynFlags -import FastString -import Exception - -import Control.Applicative (Applicative(..)) -import Control.Monad -import qualified Data.ByteString as BS -import Data.Char -import System.IO - -emitExternalCore :: DynFlags -> FilePath -> CgGuts -> IO () -emitExternalCore dflags extCore_filename cg_guts - | gopt Opt_EmitExternalCore dflags - = (do handle <- openFile extCore_filename WriteMode - hPutStrLn handle (show (mkExternalCore dflags cg_guts)) - hClose handle) - `catchIO` (\_ -> pprPanic "Failed to open or write external core output file" - (text extCore_filename)) -emitExternalCore _ _ _ - | otherwise - = return () - --- Reinventing the Reader monad; whee. -newtype CoreM a = CoreM (CoreState -> (CoreState, a)) -data CoreState = CoreState { - cs_dflags :: DynFlags, - cs_module :: Module - } - -instance Functor CoreM where - fmap = liftM - -instance Applicative CoreM where - pure = return - (<*>) = ap - -instance Monad CoreM where - (CoreM m) >>= f = CoreM (\ s -> case m s of - (s',r) -> case f r of - CoreM f' -> f' s') - return x = CoreM (\ s -> (s, x)) -runCoreM :: CoreM a -> CoreState -> a -runCoreM (CoreM f) s = snd $ f s -ask :: CoreM CoreState -ask = CoreM (\ s -> (s,s)) - -instance HasDynFlags CoreM where - getDynFlags = liftM cs_dflags ask - -mkExternalCore :: DynFlags -> CgGuts -> C.Module --- The ModGuts has been tidied, but the implicit bindings have --- not been injected, so we have to add them manually here --- We don't include the strange data-con *workers* because they are --- implicit in the data type declaration itself -mkExternalCore dflags (CgGuts {cg_module=this_mod, cg_tycons = tycons, - cg_binds = binds}) -{- Note that modules can be mutually recursive, but even so, we - print out dependency information within each module. -} - = C.Module (mname dflags) tdefs (runCoreM (mapM (make_vdef True) binds) initialState) - where - initialState = CoreState { - cs_dflags = dflags, - cs_module = this_mod - } - mname dflags = make_mid dflags this_mod - tdefs = foldr (collect_tdefs dflags) [] tycons - -collect_tdefs :: DynFlags -> TyCon -> [C.Tdef] -> [C.Tdef] -collect_tdefs dflags tcon tdefs - | isAlgTyCon tcon = tdef: tdefs - where - tdef | isNewTyCon tcon = - C.Newtype (qtc dflags tcon) - (qcc dflags (newTyConCo tcon)) - (map make_tbind tyvars) - (make_ty dflags (snd (newTyConRhs tcon))) - | otherwise = - C.Data (qtc dflags tcon) (map make_tbind tyvars) - (map (make_cdef dflags) (tyConDataCons tcon)) - tyvars = tyConTyVars tcon - -collect_tdefs _ _ tdefs = tdefs - -qtc :: DynFlags -> TyCon -> C.Qual C.Tcon -qtc dflags = make_con_qid dflags . tyConName - -qcc :: DynFlags -> CoAxiom br -> C.Qual C.Tcon -qcc dflags = make_con_qid dflags . co_ax_name - -make_cdef :: DynFlags -> DataCon -> C.Cdef -make_cdef dflags dcon = C.Constr dcon_name existentials tys - where - dcon_name = make_qid dflags False False (dataConName dcon) - existentials = map make_tbind ex_tyvars - ex_tyvars = dataConExTyVars dcon - tys = map (make_ty dflags) (dataConRepArgTys dcon) - -make_tbind :: TyVar -> C.Tbind -make_tbind tv = (make_var_id (tyVarName tv), make_kind (tyVarKind tv)) - -make_vbind :: DynFlags -> Var -> C.Vbind -make_vbind dflags v = (make_var_id (Var.varName v), make_ty dflags (varType v)) - -make_vdef :: Bool -> CoreBind -> CoreM C.Vdefg -make_vdef topLevel b = - case b of - NonRec v e -> f (v,e) >>= (return . C.Nonrec) - Rec ves -> mapM f ves >>= (return . C.Rec) - where - f :: (CoreBndr,CoreExpr) -> CoreM C.Vdef - f (v,e) = do - localN <- isALocal vName - let local = not topLevel || localN - rhs <- make_exp e - -- use local flag to determine where to add the module name - dflags <- getDynFlags - return (local, make_qid dflags local True vName, make_ty dflags (varType v),rhs) - where vName = Var.varName v - -make_exp :: CoreExpr -> CoreM C.Exp -make_exp (Var v) = do - let vName = Var.varName v - isLocal <- isALocal vName - dflags <- getDynFlags - return $ - case idDetails v of - FCallId (CCall (CCallSpec (StaticTarget nm _ True) callconv _)) - -> C.External (unpackFS nm) (showPpr dflags callconv) (make_ty dflags (varType v)) - FCallId (CCall (CCallSpec (StaticTarget _ _ False) _ _)) -> - panic "make_exp: FFI values not supported" - FCallId (CCall (CCallSpec DynamicTarget callconv _)) - -> C.DynExternal (showPpr dflags callconv) (make_ty dflags (varType v)) - -- Constructors are always exported, so make sure to declare them - -- with qualified names - DataConWorkId _ -> C.Var (make_var_qid dflags False vName) - DataConWrapId _ -> C.Var (make_var_qid dflags False vName) - _ -> C.Var (make_var_qid dflags isLocal vName) -make_exp (Lit (MachLabel s _ _)) = return $ C.Label (unpackFS s) -make_exp (Lit l) = do dflags <- getDynFlags - return $ C.Lit (make_lit dflags l) -make_exp (App e (Type t)) = do b <- make_exp e - dflags <- getDynFlags - return $ C.Appt b (make_ty dflags t) -make_exp (App _e (Coercion _co)) = error "make_exp (App _ (Coercion _))" -- TODO -make_exp (App e1 e2) = do - rator <- make_exp e1 - rand <- make_exp e2 - return $ C.App rator rand -make_exp (Lam v e) | isTyVar v = make_exp e >>= (\ b -> - return $ C.Lam (C.Tb (make_tbind v)) b) -make_exp (Lam v e) | otherwise = do b <- make_exp e - dflags <- getDynFlags - return $ C.Lam (C.Vb (make_vbind dflags v)) b -make_exp (Cast e co) = do b <- make_exp e - dflags <- getDynFlags - return $ C.Cast b (make_co dflags co) -make_exp (Let b e) = do - vd <- make_vdef False b - body <- make_exp e - return $ C.Let vd body -make_exp (Case e v ty alts) = do - scrut <- make_exp e - newAlts <- mapM make_alt alts - dflags <- getDynFlags - return $ C.Case scrut (make_vbind dflags v) (make_ty dflags ty) newAlts -make_exp (Tick _ e) = make_exp e >>= (return . C.Tick "SCC") -- temporary -make_exp _ = error "MkExternalCore died: make_exp" - -make_alt :: CoreAlt -> CoreM C.Alt -make_alt (DataAlt dcon, vs, e) = do - newE <- make_exp e - dflags <- getDynFlags - return $ C.Acon (make_con_qid dflags (dataConName dcon)) - (map make_tbind tbs) - (map (make_vbind dflags) vbs) - newE - where (tbs,vbs) = span isTyVar vs -make_alt (LitAlt l,_,e) = do x <- make_exp e - dflags <- getDynFlags - return $ C.Alit (make_lit dflags l) x -make_alt (DEFAULT,[],e) = make_exp e >>= (return . C.Adefault) --- This should never happen, as the DEFAULT alternative binds no variables, --- but we might as well check for it: -make_alt a@(DEFAULT,_ ,_) = pprPanic ("MkExternalCore: make_alt: DEFAULT " - ++ "alternative had a non-empty var list") (ppr a) - - -make_lit :: DynFlags -> Literal -> C.Lit -make_lit dflags l = - case l of - -- Note that we need to check whether the character is "big". - -- External Core only allows character literals up to '\xff'. - MachChar i | i <= chr 0xff -> C.Lchar i t - -- For a character bigger than 0xff, we represent it in ext-core - -- as an int lit with a char type. - MachChar i -> C.Lint (fromIntegral $ ord i) t - MachStr s -> C.Lstring (BS.unpack s) t - MachNullAddr -> C.Lint 0 t - MachInt i -> C.Lint i t - MachInt64 i -> C.Lint i t - MachWord i -> C.Lint i t - MachWord64 i -> C.Lint i t - MachFloat r -> C.Lrational r t - MachDouble r -> C.Lrational r t - LitInteger i _ -> C.Lint i t - _ -> pprPanic "MkExternalCore died: make_lit" (ppr l) - where - t = make_ty dflags (literalType l) - --- Expand type synonyms, then convert. -make_ty :: DynFlags -> Type -> C.Ty -- Be sure to expand types recursively! - -- example: FilePath ~> String ~> [Char] -make_ty dflags t | Just expanded <- tcView t = make_ty dflags expanded -make_ty dflags t = make_ty' dflags t - --- note calls to make_ty so as to expand types recursively -make_ty' :: DynFlags -> Type -> C.Ty -make_ty' _ (TyVarTy tv) = C.Tvar (make_var_id (tyVarName tv)) -make_ty' dflags (AppTy t1 t2) = C.Tapp (make_ty dflags t1) (make_ty dflags t2) -make_ty' dflags (FunTy t1 t2) = make_ty dflags (TyConApp funTyCon [t1,t2]) -make_ty' dflags (ForAllTy tv t) = C.Tforall (make_tbind tv) (make_ty dflags t) -make_ty' dflags (TyConApp tc ts) = make_tyConApp dflags tc ts -make_ty' _ (LitTy {}) = panic "MkExernalCore can't do literal types yet" - --- Newtypes are treated just like any other type constructor; not expanded --- Reason: predTypeRep does substitution and, while substitution deals --- correctly with name capture, it's only correct if you see the uniques! --- If you just see occurrence names, name capture may occur. --- Example: newtype A a = A (forall b. b -> a) --- test :: forall q b. q -> A b --- test _ = undefined --- Here the 'a' gets substituted by 'b', which is captured. --- Another solution would be to expand newtypes before tidying; but that would --- expose the representation in interface files, which definitely isn't right. --- Maybe CoreTidy should know whether to expand newtypes or not? - -make_tyConApp :: DynFlags -> TyCon -> [Type] -> C.Ty -make_tyConApp dflags tc ts = - foldl C.Tapp (C.Tcon (qtc dflags tc)) - (map (make_ty dflags) ts) - -make_kind :: Kind -> C.Kind -make_kind (FunTy k1 k2) = C.Karrow (make_kind k1) (make_kind k2) -make_kind k - | isLiftedTypeKind k = C.Klifted - | isUnliftedTypeKind k = C.Kunlifted - | isOpenTypeKind k = C.Kopen -make_kind _ = error "MkExternalCore died: make_kind" - -{- Id generation. -} - -make_id :: Bool -> Name -> C.Id --- include uniques for internal names in order to avoid name shadowing -make_id _is_var nm = ((occNameString . nameOccName) nm) - ++ (if isInternalName nm then (show . nameUnique) nm else "") - -make_var_id :: Name -> C.Id -make_var_id = make_id True - --- It's important to encode the module name here, because in External Core, --- base:GHC.Base => base:GHCziBase --- We don't do this in pprExternalCore because we --- *do* want to keep the package name (we don't want baseZCGHCziBase, --- because that would just be ugly.) --- SIGH. --- We encode the package name as well. -make_mid :: DynFlags -> Module -> C.Id --- Super ugly code, but I can't find anything else that does quite what I --- want (encodes the hierarchical module name without encoding the colon --- that separates the package name from it.) -make_mid dflags m - = showSDoc dflags $ - (text $ zEncodeString $ packageIdString $ modulePackageId m) - <> text ":" - <> (pprEncoded $ pprModuleName $ moduleName m) - where pprEncoded = pprCode CStyle - -make_qid :: DynFlags -> Bool -> Bool -> Name -> C.Qual C.Id -make_qid dflags force_unqual is_var n = (mname,make_id is_var n) - where mname = - case nameModule_maybe n of - Just m | not force_unqual -> make_mid dflags m - _ -> "" - -make_var_qid :: DynFlags -> Bool -> Name -> C.Qual C.Id -make_var_qid dflags force_unqual = make_qid dflags force_unqual True - -make_con_qid :: DynFlags -> Name -> C.Qual C.Id -make_con_qid dflags = make_qid dflags False False - -make_co :: DynFlags -> Coercion -> C.Coercion -make_co dflags (Refl r ty) = C.ReflCoercion (make_role r) $ make_ty dflags ty -make_co dflags (TyConAppCo r tc cos) = C.TyConAppCoercion (make_role r) (qtc dflags tc) (map (make_co dflags) cos) -make_co dflags (AppCo c1 c2) = C.AppCoercion (make_co dflags c1) (make_co dflags c2) -make_co dflags (ForAllCo tv co) = C.ForAllCoercion (make_tbind tv) (make_co dflags co) -make_co _ (CoVarCo cv) = C.CoVarCoercion (make_var_id (coVarName cv)) -make_co dflags (AxiomInstCo cc ind cos) = C.AxiomCoercion (qcc dflags cc) ind (map (make_co dflags) cos) -make_co dflags (UnivCo r t1 t2) = C.UnivCoercion (make_role r) (make_ty dflags t1) (make_ty dflags t2) -make_co dflags (SymCo co) = C.SymCoercion (make_co dflags co) -make_co dflags (TransCo c1 c2) = C.TransCoercion (make_co dflags c1) (make_co dflags c2) -make_co dflags (NthCo d co) = C.NthCoercion d (make_co dflags co) -make_co dflags (LRCo lr co) = C.LRCoercion (make_lr lr) (make_co dflags co) -make_co dflags (InstCo co ty) = C.InstCoercion (make_co dflags co) (make_ty dflags ty) -make_co dflags (SubCo co) = C.SubCoercion (make_co dflags co) -make_co _ (AxiomRuleCo {}) = panic "make_co AxiomRuleCo: not yet implemented" - - -make_lr :: LeftOrRight -> C.LeftOrRight -make_lr CLeft = C.CLeft -make_lr CRight = C.CRight - -make_role :: Role -> C.Role -make_role Nominal = C.Nominal -make_role Representational = C.Representational -make_role Phantom = C.Phantom - -------- -isALocal :: Name -> CoreM Bool -isALocal vName = do - modName <- liftM cs_module ask - return $ case nameModule_maybe vName of - -- Not sure whether isInternalName corresponds to "local"ness - -- in the External Core sense; need to re-read the spec. - Just m | m == modName -> isInternalName vName - _ -> False -\end{code} - - - - diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs index 35c0630736..f86a911ede 100644 --- a/compiler/coreSyn/PprCore.lhs +++ b/compiler/coreSyn/PprCore.lhs @@ -121,7 +121,7 @@ ppr_expr add_par (Cast expr co) if gopt Opt_SuppressCoercions dflags then ptext (sLit "...") else parens $ - sep [ppr co, dcolon <+> pprEqPred (coercionKind co)] + sep [ppr co, dcolon <+> ppr (coercionType co)] ppr_expr add_par expr@(Lam _ _) diff --git a/compiler/coreSyn/PprExternalCore.lhs b/compiler/coreSyn/PprExternalCore.lhs deleted file mode 100644 index 7fd3ac1d65..0000000000 --- a/compiler/coreSyn/PprExternalCore.lhs +++ /dev/null @@ -1,260 +0,0 @@ -% -% (c) The University of Glasgow 2001-2006 -% - -\begin{code} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module PprExternalCore () where - -import Encoding -import ExternalCore - -import Pretty -import Data.Char -import Data.Ratio - -instance Show Module where - showsPrec _ m = shows (pmodule m) - -instance Show Tdef where - showsPrec _ t = shows (ptdef t) - -instance Show Cdef where - showsPrec _ c = shows (pcdef c) - -instance Show Vdefg where - showsPrec _ v = shows (pvdefg v) - -instance Show Exp where - showsPrec _ e = shows (pexp e) - -instance Show Alt where - showsPrec _ a = shows (palt a) - -instance Show Ty where - showsPrec _ t = shows (pty t) - -instance Show Kind where - showsPrec _ k = shows (pkind k) - -instance Show Lit where - showsPrec _ l = shows (plit l) - - -indent :: Doc -> Doc -indent = nest 2 - -pmodule :: Module -> Doc -pmodule (Module mname tdefs vdefgs) = - (text "%module" <+> text mname) - $$ indent ((vcat (map ((<> char ';') . ptdef) tdefs)) - $$ (vcat (map ((<> char ';') . pvdefg) vdefgs))) - -ptdef :: Tdef -> Doc -ptdef (Data tcon tbinds cdefs) = - (text "%data" <+> pqname tcon <+> (hsep (map ptbind tbinds)) <+> char '=') - $$ indent (braces ((vcat (punctuate (char ';') (map pcdef cdefs))))) - -ptdef (Newtype tcon coercion tbinds rep) = - text "%newtype" <+> pqname tcon <+> pqname coercion - <+> (hsep (map ptbind tbinds)) $$ indent repclause - where repclause = char '=' <+> pty rep - -pcdef :: Cdef -> Doc -pcdef (Constr dcon tbinds tys) = - (pqname dcon) <+> (sep [hsep (map pattbind tbinds),sep (map paty tys)]) -pcdef (GadtConstr dcon ty) = - (pqname dcon) <+> text "::" <+> pty ty - -pname :: Id -> Doc -pname id = text (zEncodeString id) - -pqname :: Qual Id -> Doc -pqname ("",id) = pname id -pqname (m,id) = text m <> char '.' <> pname id - -ptbind, pattbind :: Tbind -> Doc -ptbind (t,Klifted) = pname t -ptbind (t,k) = parens (pname t <> text "::" <> pkind k) - -pattbind (t,k) = char '@' <> ptbind (t,k) - -pakind, pkind :: Kind -> Doc -pakind (Klifted) = char '*' -pakind (Kunlifted) = char '#' -pakind (Kopen) = char '?' -pakind k = parens (pkind k) - -pkind (Karrow k1 k2) = parens (pakind k1 <> text "->" <> pkind k2) -pkind k = pakind k - -paty, pbty, pty :: Ty -> Doc --- paty: print in parens, if non-atomic (like a name) --- pbty: print in parens, if arrow (used only for lhs of arrow) --- pty: not in parens -paty (Tvar n) = pname n -paty (Tcon c) = pqname c -paty t = parens (pty t) - -pbty (Tapp(Tapp(Tcon tc) t1) t2) | tc == tcArrow = parens(fsep [pbty t1, text "->",pty t2]) -pbty t = paty t - -pty (Tapp(Tapp(Tcon tc) t1) t2) | tc == tcArrow = fsep [pbty t1, text "->",pty t2] -pty (Tforall tb t) = text "%forall" <+> pforall [tb] t -pty ty@(Tapp {}) = pappty ty [] -pty ty@(Tvar {}) = paty ty -pty ty@(Tcon {}) = paty ty - -pappty :: Ty -> [Ty] -> Doc -pappty (Tapp t1 t2) ts = pappty t1 (t2:ts) -pappty t ts = sep (map paty (t:ts)) - -pforall :: [Tbind] -> Ty -> Doc -pforall tbs (Tforall tb t) = pforall (tbs ++ [tb]) t -pforall tbs t = hsep (map ptbind tbs) <+> char '.' <+> pty t - -paco, pbco, pco :: Coercion -> Doc -paco (ReflCoercion r ty) = char '<' <> pty ty <> text ">_" <> prole r -paco (TyConAppCoercion r qtc []) = pqname qtc <> char '_' <> prole r -paco (AxiomCoercion qtc i []) = pqname qtc <> char '[' <> int i <> char ']' -paco (CoVarCoercion cv) = pname cv -paco c = parens (pco c) - -pbco (TyConAppCoercion _ arr [co1, co2]) - | arr == tcArrow - = parens (fsep [pbco co1, text "->", pco co2]) -pbco co = paco co - -pco c@(ReflCoercion {}) = paco c -pco (SymCoercion co) = sep [text "%sub", paco co] -pco (TransCoercion co1 co2) = sep [text "%trans", paco co1, paco co2] -pco (TyConAppCoercion _ arr [co1, co2]) - | arr == tcArrow = fsep [pbco co1, text "->", pco co2] -pco (TyConAppCoercion r qtc cos) = parens (pqname qtc <+> sep (map paco cos)) <> char '_' <> prole r -pco co@(AppCoercion {}) = pappco co [] -pco (ForAllCoercion tb co) = text "%forall" <+> pforallco [tb] co -pco co@(CoVarCoercion {}) = paco co -pco (UnivCoercion r ty1 ty2) = sep [text "%univ", prole r, paty ty1, paty ty2] -pco (InstCoercion co ty) = sep [text "%inst", paco co, paty ty] -pco (NthCoercion i co) = sep [text "%nth", int i, paco co] -pco (AxiomCoercion qtc i cos) = pqname qtc <> char '[' <> int i <> char ']' <+> sep (map paco cos) -pco (LRCoercion CLeft co) = sep [text "%left", paco co] -pco (LRCoercion CRight co) = sep [text "%right", paco co] -pco (SubCoercion co) = sep [text "%sub", paco co] - -pappco :: Coercion -> [Coercion ] -> Doc -pappco (AppCoercion co1 co2) cos = pappco co1 (co2:cos) -pappco co cos = sep (map paco (co:cos)) - -pforallco :: [Tbind] -> Coercion -> Doc -pforallco tbs (ForAllCoercion tb co) = pforallco (tbs ++ [tb]) co -pforallco tbs co = hsep (map ptbind tbs) <+> char '.' <+> pco co - -prole :: Role -> Doc -prole Nominal = char 'N' -prole Representational = char 'R' -prole Phantom = char 'P' - -pvdefg :: Vdefg -> Doc -pvdefg (Rec vdefs) = text "%rec" $$ braces (indent (vcat (punctuate (char ';') (map pvdef vdefs)))) -pvdefg (Nonrec vdef) = pvdef vdef - -pvdef :: Vdef -> Doc --- TODO: Think about whether %local annotations are actually needed. --- Right now, the local flag is never used, because the Core doc doesn't --- explain the meaning of %local. -pvdef (_l,v,t,e) = sep [(pqname v <+> text "::" <+> pty t <+> char '='), - indent (pexp e)] - -paexp, pfexp, pexp :: Exp -> Doc -paexp (Var x) = pqname x -paexp (Dcon x) = pqname x -paexp (Lit l) = plit l -paexp e = parens(pexp e) - -plamexp :: [Bind] -> Exp -> Doc -plamexp bs (Lam b e) = plamexp (bs ++ [b]) e -plamexp bs e = sep [sep (map pbind bs) <+> text "->", - indent (pexp e)] - -pbind :: Bind -> Doc -pbind (Tb tb) = char '@' <+> ptbind tb -pbind (Vb vb) = pvbind vb - -pfexp (App e1 e2) = pappexp e1 [Left e2] -pfexp (Appt e t) = pappexp e [Right t] -pfexp e = paexp e - -pappexp :: Exp -> [Either Exp Ty] -> Doc -pappexp (App e1 e2) as = pappexp e1 (Left e2:as) -pappexp (Appt e t) as = pappexp e (Right t:as) -pappexp e as = fsep (paexp e : map pa as) - where pa (Left e) = paexp e - pa (Right t) = char '@' <+> paty t - -pexp (Lam b e) = char '\\' <+> plamexp [b] e -pexp (Let vd e) = (text "%let" <+> pvdefg vd) $$ (text "%in" <+> pexp e) -pexp (Case e vb ty alts) = sep [text "%case" <+> paty ty <+> paexp e, - text "%of" <+> pvbind vb] - $$ (indent (braces (vcat (punctuate (char ';') (map palt alts))))) -pexp (Cast e co) = (text "%cast" <+> parens (pexp e)) $$ paco co -pexp (Tick s e) = (text "%source" <+> pstring s) $$ pexp e -pexp (External n cc t) = (text "%external" <+> text cc <+> pstring n) $$ paty t -pexp (DynExternal cc t) = (text "%dynexternal" <+> text cc) $$ paty t -pexp (Label n) = (text "%label" <+> pstring n) -pexp e = pfexp e - -pvbind :: Vbind -> Doc -pvbind (x,t) = parens(pname x <> text "::" <> pty t) - -palt :: Alt -> Doc -palt (Acon c tbs vbs e) = - sep [pqname c, - sep (map pattbind tbs), - sep (map pvbind vbs) <+> text "->"] - $$ indent (pexp e) -palt (Alit l e) = - (plit l <+> text "->") - $$ indent (pexp e) -palt (Adefault e) = - (text "%_ ->") - $$ indent (pexp e) - -plit :: Lit -> Doc -plit (Lint i t) = parens (integer i <> text "::" <> pty t) --- we use (text (show (numerator r))) (and the same for denominator) --- because "(rational r)" was printing out things like "2.0e-2" (which --- isn't External Core), and (text (show r)) was printing out things --- like "((-1)/5)" which isn't either (it should be "(-1/5)"). -plit (Lrational r t) = parens (text (show (numerator r)) <+> char '%' - <+> text (show (denominator r)) <> text "::" <> pty t) -plit (Lchar c t) = parens (text ("\'" ++ escape [c] ++ "\'") <> text "::" <> pty t) --- This is a little messy. We shouldn't really be going via String. -plit (Lstring bs t) = parens (pstring str <> text "::" <> pty t) - where str = map (chr . fromIntegral) bs - -pstring :: String -> Doc -pstring s = doubleQuotes(text (escape s)) - -escape :: String -> String -escape s = foldr f [] (map ord s) - where - f cv rest - | cv > 0xFF = '\\':'x':hs ++ rest - | (cv < 0x20 || cv > 0x7e || cv == 0x22 || cv == 0x27 || cv == 0x5c) = - '\\':'x':h1:h0:rest - where (q1,r1) = quotRem cv 16 - h1 = intToDigit q1 - h0 = intToDigit r1 - hs = dropWhile (=='0') $ reverse $ mkHex cv - mkHex 0 = "" - mkHex cv = intToDigit r : mkHex q - where (q,r) = quotRem cv 16 - f cv rest = (chr cv):rest - -\end{code} - - - - diff --git a/compiler/coreSyn/TrieMap.lhs b/compiler/coreSyn/TrieMap.lhs index ac04adab1b..2744c5d0b8 100644 --- a/compiler/coreSyn/TrieMap.lhs +++ b/compiler/coreSyn/TrieMap.lhs @@ -4,14 +4,14 @@ % \begin{code} -{-# OPTIONS -fno-warn-tabs #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and -- detab the module (please do the detabbing in a separate patch). See -- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces -- for details -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RankNTypes, TypeFamilies #-} module TrieMap( CoreMap, emptyCoreMap, extendCoreMap, lookupCoreMap, foldCoreMap, TypeMap, emptyTypeMap, extendTypeMap, lookupTypeMap, foldTypeMap, |