X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FMagicUFs.lhs;fp=ghc%2Fcompiler%2FsimplCore%2FMagicUFs.lhs;h=0000000000000000000000000000000000000000;hb=69e14f75a4b031e489b7774914e5a176409cea78;hp=692209adaf8bf36ee5a80b5ed1a35c7dce4ad7b0;hpb=c9dfd084e476b18290e964e5e5d66adf0771b9e6;p=ghc-hetmet.git

diff --git a/ghc/compiler/simplCore/MagicUFs.lhs b/ghc/compiler/simplCore/MagicUFs.lhs
deleted file mode 100644
index 692209a..0000000
--- a/ghc/compiler/simplCore/MagicUFs.lhs
+++ /dev/null
@@ -1,645 +0,0 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
-%
-\section[MagicUFs]{Magic unfoldings that the simplifier knows about}
-
-\begin{code}
-module MagicUFs (
-	MagicUnfoldingFun,  -- absolutely abstract
-
-	mkMagicUnfoldingFun,
-	applyMagicUnfoldingFun
-    ) where
-
-#include "HsVersions.h"
-
-import CoreSyn
-import SimplMonad	( SimplM, SimplCont )
-import Type		( mkFunTys )
-import TysWiredIn	( mkListTy )
-import Unique		( Unique{-instances-} )
-import Util		( assoc, zipWith3Equal, nOfThem )
-import Panic		( panic )
-\end{code}
-
-%************************************************************************
-%*                                                                      *
-\subsection{Types, etc., for magic-unfolding functions}
-%*                                                                      *
-%************************************************************************
-
-\begin{code}
-data MagicUnfoldingFun
-  = MUF ( SimplCont -> Maybe (SimplM CoreExpr))
-				-- Just result, or Nothing
-\end{code}
-
-Give us a value's @Unique@, we'll give you back the corresponding MUF.
-\begin{code}
-mkMagicUnfoldingFun :: Unique -> MagicUnfoldingFun
-
-mkMagicUnfoldingFun tag
-  = assoc "mkMagicUnfoldingFun" magic_UFs_table tag
-
-magic_UFs_table = panic "MagicUFs.magic_UFs_table:ToDo"
-\end{code}
-
-Give us an MUF and stuff to apply it to, and we'll give you back the answer.
-
-\begin{code}
-applyMagicUnfoldingFun
-	:: MagicUnfoldingFun
-	-> SimplCont
-	-> Maybe (SimplM CoreExpr)
-
-applyMagicUnfoldingFun (MUF fun) cont = fun cont
-\end{code}
-
-%************************************************************************
-%*                                                                      *
-\subsection{The table of actual magic unfoldings}
-%*                                                                      *
-%************************************************************************
-
-\begin{code}
-{- LATER:
-
-magic_UFs_table :: [(FAST_STRING, MagicUnfoldingFun)]
-
-magic_UFs_table
-  = [(SLIT("augment"), 		MUF augment_fun),
-     (SLIT("build"),   		MUF build_fun),
-     (SLIT("foldl"),   		MUF foldl_fun),
-     (SLIT("foldr"),   		MUF foldr_fun),
-     (SLIT("unpackFoldrPS__"),  MUF unpack_foldr_fun),
-     (SLIT("unpackAppendPS__"),	MUF unpack_append_fun)]
-\end{code}
-
-%************************************************************************
-%*                                                                      *
-\subsubsection{Unfolding function for @append@}
-%*                                                                      *
-%************************************************************************
-
-\begin{code}
--- First build, the way we express our lists.
-
-build_fun :: SimplEnv
-	  -> [CoreArg]
-	  -> Maybe (SimplM CoreExpr)
-build_fun env [TypeArg ty,ValArg (VarArg e)]
-  | switchIsSet env SimplDoInlineFoldrBuild
-  = Just result
-  where
-    tyL     = mkListTy ty
-    ourCons = CoTyApp (Var consDataCon) ty
-    ourNil  = CoTyApp (Var nilDataCon) ty
-
-    result = newIds  [ mkFunTys [ty, tyL] tyL, tyL ]	`thenSmpl` \ [c,n] ->
-	     returnSmpl(Let (NonRec c ourCons)
-		       (Let (NonRec n ourNil)
-		       (App (App (CoTyApp (Var e) tyL) (VarArg c)) (VarArg n)))
-
--- ToDo: add `build' without an argument instance.
--- This is strange, because of g's type.
-build_fun env _ = ASSERT (not (switchIsSet env SimplDoInlineFoldrBuild))
-	  	  Nothing
-\end{code}
-
-\begin{code}
-augment_fun :: SimplEnv
-	  -> [CoreArg]
-	  -> Maybe (SimplM CoreExpr)
-
-augment_fun env [TypeArg ty,ValArg (VarArg e),ValArg nil]
- | switchIsSet env SimplDoInlineFoldrBuild
- = Just result
- where
-   tyL     = mkListTy ty
-   ourCons = CoTyApp (Var consDataCon) ty
-   result = newId  (mkFunTys [ty, tyL] tyL)    `thenSmpl` \ c ->
-	    returnSmpl (Let (NonRec c ourCons)
-		       (App (App (CoTyApp (Var e) tyL) (VarArg c)) nil))
--- ToDo: add `build' without an argument instance.
--- This is strange, because of g's type.
-
-augment_fun env _ = ASSERT (not (switchIsSet env SimplDoInlineFoldrBuild))
-		    Nothing
-\end{code}
-
-Now foldr, the way we consume lists.
-
-\begin{code}
-foldr_fun :: SimplEnv
-	  -> [CoreArg]
-	  -> Maybe (SimplM CoreExpr)
-
-foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:rest_args)
-  | do_fb_red && isConsFun env arg_k && isNilForm env arg_z
-        -- foldr (:) [] ==> id
-	-- this transformation is *always* benificial
-	-- cf.  foldr (:) [] (build g) == g (:) []
-	-- with foldr (:) [] (build g) == build g
-	-- after unfolding build, they are the same thing.
-  = Just (tick Foldr_Cons_Nil		`thenSmpl_`
-	  newId (mkListTy ty1) 		`thenSmpl` \ x ->
-          returnSmpl({-trace "foldr (:) []"-} (mkGenApp (Lam x (Var x)) rest_args))
-    )
- where
-   do_fb_red		= switchIsSet env SimplDoFoldrBuild
-
-foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:ValArg arg_list:rest_args)
- | do_fb_red && isNilForm env arg_list
-        -- foldr f z [] = z
-	-- again another short cut, helps with unroling of constant lists
- = Just (tick Foldr_Nil	`thenSmpl_`
-	 returnSmpl (argToExpr arg_z)
-   )
-
-  | do_fb_red && arg_list_isBuildForm
-        -- foldr k z (build g) ==> g k z
-	-- this next line *is* the foldr/build rule proper.
-  = Just (tick FoldrBuild	`thenSmpl_`
-	  returnSmpl (mkGenApp (Var g) (TypeArg ty2:ValArg arg_k:ValArg arg_z:rest_args))
-    )
-
-  | do_fb_red && arg_list_isAugmentForm
-        -- foldr k z (augment g h) ==> let v = foldr k z h in g k v
-	-- this next line *is* the foldr/augment rule proper.
-  = Just (tick FoldrAugment	`thenSmpl_`
-	  newId ty2				`thenSmpl` \ v ->
-	  returnSmpl (
-		Let (NonRec v (mkGenApp (Var foldrId)
-					[TypeArg ty1,TypeArg ty2,
-					 ValArg arg_k,
-					 ValArg arg_z,
-					 ValArg h]))
-		(mkGenApp (Var g') (TypeArg ty2:ValArg arg_k:ValArg (VarArg v):rest_args)))
-    )
-
- | do_fb_red && arg_list_isListForm
-        -- foldr k z (a:b:c:rest) =
-	--	(\ f -> f a (f b (f c (foldr f z rest)))) k rest_args
-	-- NB: 'k' is used just one by foldr, but 'f' is used many
-	-- times inside the list structure. This means that
-	-- 'f' needs to be inside a lambda, to make sure the simplifier
-	-- realises this.
-	--
-	-- The structure of
-	--	 f a (f b (f c (foldr f z rest)))
-	-- in core becomes:
-	--	let ele_1 = foldr f z rest
-	--	    ele_2 = f c ele_1
-	--	    ele_3 = f b ele_2
-	--	in f a ele_3
-	--
-  = Just (tick Foldr_List	`thenSmpl_`
-	  newIds (
-		mkFunTys [ty1, ty2] ty2 :
-		nOfThem (length the_list) ty2
-	  )			`thenSmpl` \ (f_id:ele_id1:ele_ids) ->
-	  let
-	    fst_bind = NonRec
-			ele_id1
-			(mkGenApp (Var foldrId)
-				[TypeArg ty1,TypeArg ty2,
-				 ValArg (VarArg f_id),
-				 ValArg arg_z,
-				 ValArg the_tl])
-	    rest_binds = zipWith3Equal "Foldr:rest_binds"
-			 (\ e v e' -> NonRec e (mkRhs v e'))
-			 ele_ids
-			 (reverse (tail the_list))
-			 (init (ele_id1:ele_ids))
-	    mkRhs v e = App (App (Var f_id) v) (VarArg e)
-	    core_list = foldr
-			Let
-			(mkRhs (head the_list) (last (ele_id1:ele_ids)))
-			(fst_bind:rest_binds)
-          in
- 	  returnSmpl (mkGenApp (Lam f_id core_list) (ValArg arg_k:rest_args))
-    )
-
-
-	--
-
- | do_fb_red && arg_list_isStringForm	-- ok, its a string!
-	-- foldr f z "foo" => unpackFoldrPS__ f z "foo"#
- = Just (tick Str_FoldrStr				`thenSmpl_`
-	 returnSmpl (mkGenApp (Var unpackCStringFoldrId)
-				(TypeArg ty2:
-				 ValArg (LitArg (MachStr str_val)):
-				 ValArg arg_k:
-				 ValArg arg_z:
-				 rest_args))
-   )
- where
-   do_fb_red		= switchIsSet env SimplDoFoldrBuild
-
-   arg_list_isStringForm = maybeToBool stringForm
-   stringForm		 = getStringForm env arg_list
-   (Just str_val)	 = stringForm
-
-   arg_list_isBuildForm = maybeToBool buildForm
-   buildForm            = getBuildForm env arg_list
-   (Just g)             = buildForm
-
-   arg_list_isAugmentForm  = maybeToBool augmentForm
-   augmentForm             = getAugmentForm env arg_list
-   (Just (g',h))           = augmentForm
-
-   arg_list_isListForm      = maybeToBool listForm
-   listForm                 = getListForm env arg_list
-   (Just (the_list,the_tl)) = listForm
-{-
-   arg_list_isAppendForm = maybeToBool appendForm
-   appendForm            = getAppendForm env arg_list
-   (Just (xs,ys))        = appendForm
--}
-
-foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:rest_args)
-  | doing_inlining && isConsFun env arg_k && not dont_fold_back_append
-       -- foldr (:) z xs = xs ++ z
-  = Just (tick Foldr_Cons	`thenSmpl_`
-	   newIds [ty2,mkListTy ty1] `thenSmpl` \ [z,x] ->
-	   returnSmpl (mkGenApp
-			(Lam z (Lam x (mkGenApp
-					(Var appendId) [
-						TypeArg ty1,
-						ValArg (VarArg x),
-						ValArg (VarArg z)]))
-			rest_args))
-    )
-
-  | doing_inlining && (isInterestingArg env arg_k
-		       || isConsFun env arg_k)
-      -- foldr k args =
-      --        (\ f z xs ->
-      --          letrec
-      --             h x = case x of
-      --		    [] -> z
-      --          	    (a:b) -> f a (h b)
-      --          in
-      --             h xs) k args
-      --
---     tick FoldrInline		`thenSmpl_`
-  = Just (newIds [
-		ty1,                    -- a :: t1
-		mkListTy ty1,           -- b :: [t1]
-		ty2,                    -- v :: t2
-		mkListTy ty1,           -- x :: t1
-		mkFunTys [mkListTy ty1] ty2,
-					-- h :: [t1] -> t2
-		mkFunTys [ty1, ty2] ty2,
-					-- f
-		ty2,                    -- z
-		mkListTy ty1            -- xs
-			] `thenSmpl` \ [a,b,v,x,h,f,z,xs] ->
-	   let
-	     h_rhs = (Lam x (Case (Var x)
-		      (AlgAlts
-			  [(nilDataCon,[],argToExpr (VarArg z)),
-			   (consDataCon,[a,b],body)]
-		       NoDefault)))
-	     body = Let (NonRec v (App (Var h) (VarArg b)))
-			  (App (App (argToExpr (VarArg f))
-						  (VarArg a))
-						    (VarArg v))
-	   in
-	     returnSmpl (
-		     mkGenApp
-			 (Lam f (Lam z (Lam xs
-			  (Let (Rec [(h,h_rhs)])
-				 (App (Var h) (VarArg xs))))))
-		     (ValArg arg_k:rest_args))
-    )
-   where
-     doing_inlining = switchIsSet env SimplDoInlineFoldrBuild
-     dont_fold_back_append = switchIsSet env SimplDontFoldBackAppend
-
-foldr_fun _ _ = Nothing
-
-isConsFun :: SimplEnv -> CoreArg -> Bool
-isConsFun env (VarArg v)
-  = case lookupUnfolding env v of
-	SimpleUnfolding _ (Lam (x,_) (Lam (y,_) (Con con tys [VarArg x',VarArg y']))) _
-	  | con == consDataCon && x==x' && y==y'
-	  -> ASSERT ( length tys == 1 ) True
-	_ -> False
-isConsFun env _ = False
-
-isNilForm :: SimplEnv -> CoreArg -> Bool
-isNilForm env (VarArg v)
-  = case lookupUnfolding env v of
-	SimpleUnfolding _ (CoTyApp (Var id) _) _ | id == nilDataCon -> True
-	SimpleUnfolding _ (Lit (NoRepStr s))   _ | _NULL_ s	      -> True
-	_ 						      -> False
-isNilForm env _ = False
-
-getBuildForm :: SimplEnv -> CoreArg -> Maybe Id
-getBuildForm env (VarArg v)
-  = case lookupUnfolding env v of
-	SimpleUnfolding False _ _ _ -> Nothing
-					-- not allowed to inline :-(
-	SimpleUnfolding _ (App (CoTyApp (Var bld) _) (VarArg g)) _
-	  | bld == buildId -> Just g
-	SimpleUnfolding _ (App (App (CoTyApp (Var bld) _)
-					(VarArg g)) h) _
-	  | bld == augmentId && isNilForm env h  -> Just g
-	_ -> Nothing
-getBuildForm env _ = Nothing
-
-
-
-getAugmentForm :: SimplEnv -> CoreArg -> Maybe (Id,CoreArg)
-getAugmentForm env (VarArg v)
-  = case lookupUnfolding env v of
-	SimpleUnfolding False _ _ _ -> Nothing
-				-- not allowed to inline :-(
-	SimpleUnfolding _ (App (App (CoTyApp (Var bld) _)
-						(VarArg g)) h) _
-	  | bld == augmentId -> Just (g,h)
-	_ -> Nothing
-getAugmentForm env _ = Nothing
-
-getStringForm :: SimplEnv -> CoreArg -> Maybe FAST_STRING
-getStringForm env (LitArg (NoRepStr str)) = Just str
-getStringForm env _ = Nothing
-
-{-
-getAppendForm :: SimplEnv -> CoreArg -> Maybe (GenCoreAtom Id,GenCoreAtom Id)
-getAppendForm env (VarArg v) =
-    case lookupUnfolding env v of
-	SimpleUnfolding False _ _ _ -> Nothing	-- not allowed to inline :-(
-	SimpleUnfolding _ (App (App (App (CoTyApp (CoTyApp (Var fld) _) _) con) ys) xs) _
-	  | fld == foldrId && isConsFun env con -> Just (xs,ys)
-	_ -> Nothing
-getAppendForm env _ = Nothing
--}
-
---
--- this gets a list of the form a : b : c : d and returns ([a,b,c],d)
--- it natuarally follows that [a,b,c] => ([a,b,c],e), where e = []
---
-
-getListForm
-	:: SimplEnv
-	-> CoreArg
-	-> Maybe ([CoreArg],CoreArg)
-getListForm env (VarArg v)
-  = case lookupUnfolding env v of
-       SimpleUnfolding _ (Con id [ty_arg,head,tail]) _
-	  | id == consDataCon ->
-		case getListForm env tail of
- 		   Nothing -> Just ([head],tail)
-		   Just (lst,new_tail) -> Just (head:lst,new_tail)
-       _ -> Nothing
-getListForm env _ = Nothing
-
-isInterestingArg :: SimplEnv -> CoreArg -> Bool
-isInterestingArg env (VarArg v)
-  = case lookupUnfolding env v of
-       SimpleUnfolding False _ _ UnfoldNever -> False
-       SimpleUnfolding _ exp guide -> True
-       _ -> False
-isInterestingArg env _ = False
-
-foldl_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:ValArg arg_list:rest_args)
- | do_fb_red && isNilForm env arg_list
-        -- foldl f z [] = z
-	-- again another short cut, helps with unroling of constant lists
- = Just (tick Foldl_Nil	`thenSmpl_`
-	 returnSmpl (argToExpr arg_z)
-   )
-
-  | do_fb_red && arg_list_isBuildForm
-        -- foldl t1 t2 k z (build t3 g) ==>
-	--		   let c {- INLINE -} = \ b g' a -> g' (f a b)
-	--		       n {- INLINE -} = \ a -> a
-	--		   in g t1 c n z
-	-- this next line *is* the foldr/build rule proper.
-  = Just(tick FoldlBuild	`thenSmpl_`
-	-- c :: t2 -> (t1 -> t1) -> t1 -> t1
-	-- n :: t1 -> t1
-         newIds [
-	  {- pre_c -}	mkFunTys [ty2, mkFunTys [ty1] ty1, ty1]  ty1,
-	  {- pre_n -}	mkFunTys [ty1] ty1,
-	  {- b -}	ty2,
-	  {- g' -}	mkFunTys [ty1] ty1,
-	  {- a -}	ty1,
-	  {- a' -}	ty1,
-	  {- t -}	ty1
-	  ]		`thenSmpl` \ [pre_c,
-				      pre_n,
-				      b,
-				      g',
-				      a,
-				      a',
-				      t] ->
-
-        let
-	  c     = addInlinePragma pre_c
-	  c_rhs = Lam b (Lam g' (Lam a
-		  (Let (NonRec t (App (App (argToExpr arg_k) (VarArg a)) (VarArg b)))
-			 (App (Var g') (VarArg t)))))
-	  n     = addInlinePragma pre_n
-	  n_rhs = Lam a' (Var a')
-        in
-        returnSmpl (Let (NonRec c c_rhs) $
-		    Let (NonRec n n_rhs) $
-		    mkGenApp (Var g) 
-		    (TypeArg (mkFunTys [ty1] ty1):ValArg (VarArg c):ValArg (VarArg n)
-				:ValArg arg_z:rest_args))
-    )
-
-  | do_fb_red && arg_list_isAugmentForm
-        -- foldl t1 t2 k z (augment t3 g h) ==>
-	--		   let c {- INLINE -} = \ b g' a -> g' (f a b)
-	--		       n {- INLINE -} = \ a -> a
-	--		       r {- INLINE -} = foldr t2 (t1 -> t1) c n h
-	--		   in g t1 c r z
-	-- this next line *is* the foldr/build rule proper.
-  = Just (tick FoldlAugment	`thenSmpl_`
-	-- c :: t2 -> (t1 -> t1) -> t1 -> t1
-	-- n :: t1 -> t1
-          newIds [
-	   {- pre_c -}	mkFunTys [ty2, mkFunTys [ty1] ty1, ty1] ty1,
-	   {- pre_n -}	mkFunTys [ty1] ty1,
-	   {- pre_r -}	mkFunTys [ty1] ty1,
-	   {- b -}	ty2,
-	   {- g_ -}	mkFunTys [ty1] ty1,
-	   {- a -}	ty1,
-	   {- a' -}	ty1,
-	   {- t -}	ty1
-	   ]		`thenSmpl` \ [pre_c,
-				      pre_n,
-				      pre_r,
-				      b,
-				      g_,
-				      a,
-				      a',
-				      t] ->
-
-        let
-	  c     = addInlinePragma pre_c
-	  c_rhs = Lam b (Lam g_ (Lam a
-		  (Let (NonRec t (App (App (argToExpr arg_k) (VarArg a)) (VarArg b)))
-			 (App (Var g_) (VarArg t)))))
-	  n     = addInlinePragma pre_n
-	  n_rhs = Lam a' (Var a')
-	  r     = addInlinePragma pre_r
-	  r_rhs = mkGenApp (Var foldrId)
-					[TypeArg ty2,TypeArg (mkFunTys [ty1] ty1),
-					 ValArg (VarArg c),
-					 ValArg (VarArg n),
-					 ValArg h]
-       in
-       returnSmpl (Let (NonRec c c_rhs) $
-		   Let (NonRec n n_rhs) $
-		   Let (NonRec r r_rhs) $
-		   mkGenApp (Var g')
-		      (TypeArg (mkFunTys [ty1] ty1):ValArg (VarArg c):ValArg (VarArg r)
-				:ValArg arg_z:rest_args))
-    )
-
- | do_fb_red && arg_list_isListForm
-        -- foldl k z (a:b:c:rest) =
-	--	(\ f -> foldl f (f (f (f z a) b) c) rest) k rest_args
-	-- NB: 'k' is used just one by foldr, but 'f' is used many
-	-- times inside the list structure. This means that
-	-- 'f' needs to be inside a lambda, to make sure the simplifier
-	-- realises this.
-	--
-	-- The structure of
-	-- 	 foldl f (f (f (f z a) b) c) rest
-	--	 f a (f b (f c (foldr f z rest)))
-	-- in core becomes:
-	--	let ele_1 = f z a
-	--	    ele_2 = f ele_1 b
-	--	    ele_3 = f ele_2 c
-	--	in foldl f ele_3 rest
-	--
-  = Just (tick Foldl_List	`thenSmpl_`
-          newIds (
-		mkFunTys [ty1, ty2] ty1 :
-		nOfThem (length the_list) ty1
-	  )			`thenSmpl` \ (f_id:ele_ids) ->
-          let
-	    rest_binds = zipWith3Equal "foldl:rest_binds"
-			 (\ e v e' -> NonRec e (mkRhs v e'))
-			 ele_ids				-- :: [Id]
-			 the_list				-- :: [CoreArg]
-			 (init (arg_z:map VarArg ele_ids))	-- :: [CoreArg]
-	    mkRhs v e = App (App (Var f_id) e) v
-
-	    last_bind = mkGenApp (Var foldlId)
-				[TypeArg ty1,TypeArg ty2,
-				 ValArg (VarArg f_id),
-				 ValArg (VarArg (last ele_ids)),
-				 ValArg the_tl]
-	    core_list = foldr
-			Let
-			last_bind
-			rest_binds
-	  in
- 	  returnSmpl (mkGenApp (Lam f_id core_list)
-				      (ValArg arg_k:rest_args))
-    )
-
- where
-   do_fb_red		= switchIsSet env SimplDoFoldrBuild
-
-   arg_list_isAugmentForm  = maybeToBool augmentForm
-   augmentForm             = getAugmentForm env arg_list
-   (Just (g',h))           = augmentForm
-
-   arg_list_isBuildForm = maybeToBool buildForm
-   buildForm            = getBuildForm env arg_list
-   (Just g)             = buildForm
-
-   arg_list_isListForm      = maybeToBool listForm
-   listForm                 = getListForm env arg_list
-   (Just (the_list,the_tl)) = listForm
-
-{-
-   arg_list_isAppendForm = maybeToBool appendForm
-   appendForm            = getAppendForm env arg_list
-   (Just (xs,ys))        = appendForm
--}
-
-foldl_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:rest_args)
-  | doing_inlining && (isInterestingArg env arg_k
-		       || isConsFun env arg_k)
-      -- foldl k args =
-      --        (\ f z xs ->
-      --          letrec
-      --             h x r = case x of
-      --		      []    -> r
-      --          	      (a:b) -> h b (f r a)
-      --          in
-      --             h xs z) k args
-      --
-  = Just (
---     tick FoldrInline				`thenSmpl_`
-     newIds [
-		ty2,                    -- a :: t1
-		mkListTy ty2,           -- b :: [t1]
-		ty1,                    -- v :: t2
-		mkListTy ty2,           -- x :: t1
-		mkFunTys [mkListTy ty2, ty1] ty1,
-					-- h :: [t2] -> t1 -> t1
-		mkFunTys [ty1, ty2] ty1,
-					-- f
-		ty1,                    -- z
-		mkListTy ty2,           -- xs
-		ty1			-- r
-			] `thenSmpl` \ [a,b,v,x,h,f,z,xs,r] ->
-	   let
-	     h_rhs = (Lam x (Lam r (Case (Var x))
-		      (AlgAlts
-			  [(nilDataCon,[],argToExpr (VarArg r)),
-			   (consDataCon,[a,b],body)]
-		       NoDefault)))
-	     body = Let (NonRec v (App (App (Var f) (VarArg r))
-							      (VarArg a)))
-			  (App (App (argToExpr (VarArg h))
-						  (VarArg b))
-						    (VarArg v))
-	   in
-	     returnSmpl (
-		     (mkGenApp
-			 (Lam f (Lam z (Lam xs
-			  (Let (Rec [(h,h_rhs)])
-				 (App (App (Var h) (VarArg xs))
-							 (VarArg z))))))
-		     (ValArg arg_k:rest_args))
-   )
-   where
-	doing_inlining = switchIsSet env SimplDoInlineFoldrBuild
-
-foldl_fun env _ =  Nothing
-\end{code}
-
-
-\begin{code}
---
---  Foldr unpackFoldr "str"# (:) stuff ==> unpackAppend "str"#
---
-unpack_foldr_fun env [TypeArg ty,ValArg str,ValArg arg_k,ValArg arg_z]
-   | switchIsSet env SimplDoFoldrBuild && isConsFun env arg_k
-   = Just (tick Str_UnpackCons		`thenSmpl_`
-           returnSmpl (mkGenApp (Var unpackCStringAppendId)
-				[ValArg str,
-				 ValArg arg_z])
-     )
-unpack_foldr_fun env _ =  Nothing
-
-unpack_append_fun env
-	[ValArg (LitArg (MachStr str_val)),ValArg arg_z]
-   | switchIsSet env SimplDoFoldrBuild && isNilForm env arg_z
-   = Just (tick Str_UnpackNil		`thenSmpl_`
-	   returnSmpl (Lit (NoRepStr str_val))
-     )
-unpack_append_fun env _ =  Nothing
--}
-\end{code}