[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.

5 files changed, 14 insertions, 14 deletions

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