ghc/compiler/simplCore/FoldrBuildWW.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[FoldrBuildWW]{Spliting suitable functions into Workers and Wrappers}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module FoldrBuildWW ( mkFoldrBuildWW ) where
  10
  11 IMP_Ubiq(){-uitous-}
  12
  13 import CoreSyn          ( SYN_IE(CoreBinding) )
  14 import UniqSupply       ( UniqSupply )
  15 import Util             ( panic{-ToDo:rm?-} )
  16
  17 --import Type           ( cloneTyVarFromTemplate, mkTyVarTy,
  18 --                        splitFunTyExpandingDicts, eqTyCon,  mkForallTy )
  19 --import TysPrim                ( alphaTy )
  20 --import TyVar          ( alphaTyVar )
  21 --
  22 --import Type           ( SYN_IE(Type) ) -- **** CAN SEE THE CONSTRUCTORS ****
  23 --import UniqSupply     ( runBuiltinUs )
  24 --import WwLib            -- share the same monad (is this eticit ?)
  25 --import PrelInfo               ( listTyCon, mkListTy, nilDataCon, consDataCon,
  26 --                        foldrId, buildId
  27 --                      )
  28 --import Id               ( getIdFBTypeInfo, mkWorkerId, getIdInfo,
  29 --                        replaceIdInfo, mkSysLocal, idType
  30 --                      )
  31 --import IdInfo
  32 --import Maybes
  33 --import SrcLoc         ( mkUnknownSrcLoc, SrcLoc )
  34 --import Util
  35 \end{code}
  36
  37 \begin{code}
  38 mkFoldrBuildWW
  39         :: UniqSupply
  40         -> [CoreBinding]
  41         -> [CoreBinding]
  42
  43 mkFoldrBuildWW = panic "mkFoldrBuildWW (ToDo)"
  44
  45 {- LATER:
  46 mkFoldrBuildWW us top_binds =
  47    (mapWw wwBind top_binds `thenWw` \ top_binds2 ->
  48    returnWw (concat top_binds2)) us
  49 \end{code}
  50
  51 \begin{code}
  52 wwBind :: CoreBinding -> WwM [CoreBinding]
  53 wwBind (NonRec bndr expr)
  54   = try_split_bind bndr expr    `thenWw` \ re ->
  55     returnWw [NonRec bnds expr | (bnds,expr) <- re]
  56 wwBind (Rec binds)
  57   = mapWw (\ (bndr,expr) -> try_split_bind bndr expr) binds   `thenWw` \ res ->
  58     returnWw [Rec (concat res)]
  59
  60 wwExpr :: CoreExpr -> WwM CoreExpr
  61 wwExpr e@(Var _) = returnWw e
  62 wwExpr e@(Lit _) = returnWw e
  63 wwExpr e@(Con _ _ _) = returnWw e
  64 wwExpr e@(Prim _ _ _) = returnWw e
  65 wwExpr   (Lam ids e) =
  66         wwExpr e                `thenWw` \ e' ->
  67         returnWw (Lam ids e')
  68 wwExpr   (CoTyLam tyvar e) =
  69         wwExpr e                `thenWw` \ e' ->
  70         returnWw (CoTyLam tyvar e')
  71 wwExpr   (App f atom) =
  72         wwExpr f                `thenWw` \ f' ->
  73         returnWw (App f atom)
  74 wwExpr   (CoTyApp f ty) =
  75         wwExpr f                `thenWw` \ f' ->
  76         returnWw (CoTyApp f' ty)
  77 wwExpr   (SCC lab e) =
  78         wwExpr e                `thenWw` \ e' ->
  79         returnWw (SCC lab e')
  80 wwExpr   (Coerce c ty e) =
  81         wwExpr e                `thenWw` \ e' ->
  82         returnWw (Coerce c ty e')
  83 wwExpr   (Let bnds e) =
  84         wwExpr e                `thenWw` \ e' ->
  85         wwBind bnds             `thenWw` \ bnds' ->
  86         returnWw (foldr Let e' bnds')
  87 wwExpr   (Case e alts) =
  88         wwExpr e                `thenWw` \ e' ->
  89         wwAlts alts             `thenWw` \ alts' ->
  90         returnWw  (Case e' alts')
  91
  92 wwAlts (AlgAlts alts deflt) =
  93         mapWw (\(con,binders,e) ->
  94                         wwExpr e        `thenWw` \ e' ->
  95                         returnWw (con,binders,e')) alts `thenWw` \ alts' ->
  96         wwDef deflt                                     `thenWw` \ deflt' ->
  97         returnWw (AlgAlts alts' deflt)
  98 wwAlts (PrimAlts alts deflt) =
  99         mapWw (\(lit,e) ->
 100                         wwExpr e        `thenWw` \ e' ->
 101                         returnWw (lit,e')) alts         `thenWw` \ alts' ->
 102         wwDef deflt                                     `thenWw` \ deflt' ->
 103         returnWw (PrimAlts alts' deflt)
 104
 105 wwDef e@NoDefault = returnWw e
 106 wwDef  (BindDefault v e) =
 107         wwExpr e                                        `thenWw` \ e' ->
 108         returnWw (BindDefault v e')
 109 \end{code}
 110
 111 \begin{code}
 112 try_split_bind :: Id -> CoreExpr -> WwM [(Id,CoreExpr)]
 113 try_split_bind id expr =
 114   wwExpr expr                   `thenWw` \ expr' ->
 115   case getFBType (getIdFBTypeInfo id) of
 116     Just (FBType consum prod)
 117         |  FBGoodProd == prod ->
 118 {-      || any (== FBGoodConsum) consum -}
 119       let
 120         (use_args,big_args,args,body) = collectBinders expr'
 121       in
 122         if length args /= length consum   -- funny number of arguments
 123         then returnWw [(id,expr')]
 124         else
 125         -- f /\ t1 .. tn \ v1 .. vn -> e
 126         --      ===>
 127         -- f_wrk /\ t1 .. tn t_new \ v1 .. vn c n -> foldr <exprTy> <nTy> c n e
 128         -- f /\ t1 .. tn \ v1 .. vn
 129         --      -> build exprTy (\ c n -> f_wrk t1 .. tn t_new v1 .. vn c n)
 130         pprTrace "WW:" (ppr PprDebug id) (returnWw ())
 131                                 `thenWw` \ () ->
 132         getUniqueWw             `thenWw` \ ty_new_uq ->
 133         getUniqueWw             `thenWw` \ worker_new_uq ->
 134         getUniqueWw             `thenWw` \ c_new_uq ->
 135         getUniqueWw             `thenWw` \ n_new_uq ->
 136       let
 137         -- The *new* type
 138         n_ty = alphaTy
 139         n_ty_templ = alphaTy
 140
 141         (templ,arg_tys,res) = splitFunTyExpandingDicts (idType id)
 142         expr_ty = getListTy res
 143         getListTy res = panic "FoldrBuildWW:getListTy:ToDo" {-LATER:case res of
 144                          UniData lty [ty] | lty `eqTyCon` listTyCon -> ty
 145                          _ -> panic "Trying to split a non List datatype into Worker/Wrapper"-}
 146
 147         c_ty       = expr_ty `mkFunTy` (n_ty `mkFunTy` n_ty)
 148         c_ty_templ = expr_ty `mkFunTy` (n_ty_templ `mkFunTy` n_ty_templ)
 149
 150         worker_ty = mkForallTy (templ  ++ [alphaTyVar])
 151                         (foldr mkFunTy n_ty_templ (arg_tys++[c_ty_templ,n_ty_templ]))
 152         wrapper_id  = id `replaceIdInfo`
 153                               (getIdInfo id     `addInfo_UF`
 154                                iWantToBeINLINEd UnfoldAlways)
 155         worker_id  = mkWorkerId worker_new_uq id worker_ty
 156                                 noIdInfo
 157                 -- TODO : CHECK if mkWorkerId is thr
 158                 -- right function to use ..
 159         -- Now the bodies
 160
 161         c_id = mkSysLocal SLIT("fbww") c_new_uq c_ty mkUnknownSrcLoc
 162         n_id = mkSysLocal SLIT("fbww") n_new_uq n_ty mkUnknownSrcLoc
 163         worker_rhs
 164           = mkTyLam [] (big_args ++ [alphaTyVar]) (args++[c_id,n_id]) worker_body
 165
 166         worker_body = runBuiltinUs (
 167           mkCoApps
 168             (Var foldrId `CoTyApp` expr_ty `CoTyApp` n_ty `App`
 169                VarArg c_id `App` VarArg n_id)
 170             [body])
 171         wrapper_rhs = mkLam big_args args wrapper_body
 172
 173         wrapper_body = runBuiltinUs (
 174                  mkCoApps (CoTyApp (Var buildId) expr_ty)
 175                                 [mkLam [alphaTyVar] [c_id,n_id]
 176                 (foldl App
 177                         (mkCoTyApps (Var worker_id)
 178                                 [mkTyVarTy t | t <- big_args ++ [alphaTyVar]])
 179                         (map VarArg (args++[c_id,n_id])))])
 180
 181       in
 182         if length args /= length arg_tys ||
 183            length big_args /= length templ
 184         then panic "LEN PROBLEM"
 185         else
 186         returnWw  [(worker_id,worker_rhs),(wrapper_id,wrapper_rhs)]
 187     _ -> returnWw [(id,expr')]
 188 -}
 189 \end{code}