From 958924a2b338aebbcc8a88ba2cab511517762a19 Mon Sep 17 00:00:00 2001 From: simonpj Date: Thu, 27 Oct 2005 14:35:21 +0000 Subject: [project @ 2005-10-27 14:35:20 by simonpj] Add a new pragma: SPECIALISE INLINE This amounts to adding an INLINE pragma to the specialised version of the function. You can add phase stuff too (SPECIALISE INLINE [2]), and NOINLINE instead of INLINE. The reason for doing this is to support inlining of type-directed recursive functions. The main example is this: -- non-uniform array type data Arr e where ArrInt :: !Int -> ByteArray# -> Arr Int ArrPair :: !Int -> Arr e1 -> Arr e2 -> Arr (e1, e2) (!:) :: Arr e -> Int -> e {-# SPECIALISE INLINE (!:) :: Arr Int -> Int -> Int #-} {-# SPECIALISE INLINE (!:) :: Arr (a, b) -> Int -> (a, b) #-} ArrInt _ ba !: (I# i) = I# (indexIntArray# ba i) ArrPair _ a1 a2 !: i = (a1 !: i, a2 !: i) If we use (!:) at a particular array type, we want to inline (:!), which is recursive, until all the type specialisation is done. On the way I did a bit of renaming and tidying of the way that pragmas are carried, so quite a lot of files are touched in a fairly trivial way. --- ghc/compiler/rename/RnBinds.lhs | 18 +++++++++--------- ghc/compiler/rename/RnExpr.lhs | 2 +- ghc/compiler/rename/RnHsSyn.lhs | 4 ++-- ghc/compiler/rename/RnNames.lhs | 2 +- ghc/compiler/rename/RnSource.lhs | 2 +- 5 files changed, 14 insertions(+), 14 deletions(-) (limited to 'ghc/compiler/rename') diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs index f067e5d5d3..3c23aba712 100644 --- a/ghc/compiler/rename/RnBinds.lhs +++ b/ghc/compiler/rename/RnBinds.lhs @@ -188,7 +188,7 @@ rnTopBindsSrc binds@(ValBindsIn mbinds _) -- Warn about missing signatures, ; let { ValBindsOut _ sigs' = binds' - ; ty_sig_vars = mkNameSet [ unLoc n | L _ (Sig n _) <- sigs'] + ; ty_sig_vars = mkNameSet [ unLoc n | L _ (TypeSig n _) <- sigs'] ; un_sigd_bndrs = duDefs dus `minusNameSet` ty_sig_vars } ; warn_missing_sigs <- doptM Opt_WarnMissingSigs @@ -361,8 +361,8 @@ mkSigTvFn sigs where env :: NameEnv [Name] env = mkNameEnv [ (name, map hsLTyVarName ltvs) - | L _ (Sig (L _ name) - (L _ (HsForAllTy Explicit ltvs _ _))) <- sigs] + | L _ (TypeSig (L _ name) + (L _ (HsForAllTy Explicit ltvs _ _))) <- sigs] -- Note the pattern-match on "Explicit"; we only bind -- type variables from signatures with an explicit top-level for-all @@ -522,23 +522,23 @@ check_sigs ok_sig sigs renameSig :: Sig RdrName -> RnM (Sig Name) -- FixitSig is renamed elsewhere. -renameSig (Sig v ty) +renameSig (TypeSig v ty) = lookupLocatedSigOccRn v `thenM` \ new_v -> rnHsSigType (quotes (ppr v)) ty `thenM` \ new_ty -> - returnM (Sig new_v new_ty) + returnM (TypeSig new_v new_ty) renameSig (SpecInstSig ty) = rnLHsType (text "A SPECIALISE instance pragma") ty `thenM` \ new_ty -> returnM (SpecInstSig new_ty) -renameSig (SpecSig v ty) +renameSig (SpecSig v ty inl) = lookupLocatedSigOccRn v `thenM` \ new_v -> rnHsSigType (quotes (ppr v)) ty `thenM` \ new_ty -> - returnM (SpecSig new_v new_ty) + returnM (SpecSig new_v new_ty inl) -renameSig (InlineSig b v p) +renameSig (InlineSig v s) = lookupLocatedSigOccRn v `thenM` \ new_v -> - returnM (InlineSig b new_v p) + returnM (InlineSig new_v s) \end{code} diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index 59f70767fc..53a412f765 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -35,7 +35,7 @@ import PrelNames ( thFAKE, hasKey, assertIdKey, assertErrorName, negateName, thenMName, bindMName, failMName ) import Name ( Name, nameOccName, nameIsLocalOrFrom ) import NameSet -import RdrName ( RdrName, emptyGlobalRdrEnv, plusGlobalRdrEnv, extendLocalRdrEnv, lookupLocalRdrEnv ) +import RdrName ( RdrName, emptyGlobalRdrEnv, extendLocalRdrEnv, lookupLocalRdrEnv ) import LoadIface ( loadHomeInterface ) import UnicodeUtil ( stringToUtf8 ) import UniqFM ( isNullUFM ) diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs index 6ce037970f..8143a520ae 100644 --- a/ghc/compiler/rename/RnHsSyn.lhs +++ b/ghc/compiler/rename/RnHsSyn.lhs @@ -111,9 +111,9 @@ In all cases this is set up for interface-file declarations: hsSigsFVs :: [LSig Name] -> FreeVars hsSigsFVs sigs = plusFVs (map (hsSigFVs.unLoc) sigs) -hsSigFVs (Sig v ty) = extractHsTyNames ty +hsSigFVs (TypeSig v ty) = extractHsTyNames ty hsSigFVs (SpecInstSig ty) = extractHsTyNames ty -hsSigFVs (SpecSig v ty) = extractHsTyNames ty +hsSigFVs (SpecSig v ty inl) = extractHsTyNames ty hsSigFVs other = emptyFVs ---------------- diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index 1fddb33abd..bf6e54a4f5 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -351,7 +351,7 @@ getLocalDeclBinders gbl_env (HsGroup {hs_valds = ValBindsIn val_decls val_sigs, new_simple rdr_name = newTopSrcBinder mod Nothing rdr_name - sig_hs_bndrs = [nm | L _ (Sig nm _) <- val_sigs] + sig_hs_bndrs = [nm | L _ (TypeSig nm _) <- val_sigs] val_hs_bndrs = collectHsBindLocatedBinders val_decls for_hs_bndrs = [nm | L _ (ForeignImport nm _ _ _) <- foreign_decls] diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 84ff47d948..4bb9bd0bf0 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -504,7 +504,7 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, -- Check the signatures -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs). let - sig_rdr_names_w_locs = [op | L _ (Sig op _) <- sigs] + sig_rdr_names_w_locs = [op | L _ (TypeSig op _) <- sigs] in checkDupNames sig_doc sig_rdr_names_w_locs `thenM_` -- Typechecker is responsible for checking that we only -- cgit v1.2.1