[project @ 1998-12-02 13:17:09 by simonm]

[ghc-hetmet.git] / ghc / compiler / simplCore / FoldrBuildWW.lhs

diff --git a/ghc/compiler/simplCore/FoldrBuildWW.lhs b/ghc/compiler/simplCore/FoldrBuildWW.lhs
index e5903cb..266a617 100644 (file)
--- a/ghc/compiler/simplCore/FoldrBuildWW.lhs
+++ b/ghc/compiler/simplCore/FoldrBuildWW.lhs
@@ -1,43 +1,43 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
 \section[FoldrBuildWW]{Spliting suitable functions into Workers and Wrappers}
 
 \begin{code}
-#include "HsVersions.h"
-
 module FoldrBuildWW ( mkFoldrBuildWW ) where
 
-IMP_Ubiq(){-uitous-}
+#include "HsVersions.h"
 
-import CoreSyn         ( CoreBinding(..) )
-import Util            ( panic{-ToDo:rm?-} )
+-- Just a stub for now
+import CoreSyn         ( CoreBind )
+import UniqSupply      ( UniqSupply )
+import Util            ( panic )
 
 --import Type          ( cloneTyVarFromTemplate, mkTyVarTy,
 --                       splitFunTyExpandingDicts, eqTyCon,  mkForallTy )
 --import TysPrim               ( alphaTy )
 --import TyVar         ( alphaTyVar )
 --
---import Type          ( Type(..) ) -- **** CAN SEE THE CONSTRUCTORS ****
+--import Type          ( Type ) -- **** CAN SEE THE CONSTRUCTORS ****
 --import UniqSupply    ( runBuiltinUs )
 --import WwLib            -- share the same monad (is this eticit ?)
 --import PrelInfo              ( listTyCon, mkListTy, nilDataCon, consDataCon,
 --                       foldrId, buildId
 --                     )
 --import Id               ( getIdFBTypeInfo, mkWorkerId, getIdInfo,
---                       replaceIdInfo, mkSysLocal, idType
+--                       mkSysLocal, idType
 --                     )
 --import IdInfo
 --import Maybes
---import SrcLoc                ( mkUnknownSrcLoc, SrcLoc )
+--import SrcLoc                ( noSrcLoc, SrcLoc )
 --import Util
 \end{code}
 
 \begin{code}
 mkFoldrBuildWW
        :: UniqSupply
-       -> [CoreBinding]
-       -> [CoreBinding]
+       -> [CoreBind]
+       -> [CoreBind]
 
 mkFoldrBuildWW = panic "mkFoldrBuildWW (ToDo)"
 
@@ -73,12 +73,9 @@ wwExpr   (App f atom) =
 wwExpr   (CoTyApp f ty) =
        wwExpr f                `thenWw` \ f' ->
        returnWw (CoTyApp f' ty)
-wwExpr   (SCC lab e) =
-       wwExpr e                `thenWw` \ e' ->
-       returnWw (SCC lab e')
-wwExpr   (Coerce c ty e) =
+wwExpr   (Note note e) =
        wwExpr e                `thenWw` \ e' ->
-       returnWw (Coerce c ty e')
+       returnWw (Note note e')
 wwExpr   (Let bnds e) =
        wwExpr e                `thenWw` \ e' ->
        wwBind bnds             `thenWw` \ bnds' ->
@@ -116,7 +113,7 @@ try_split_bind id expr =
        |  FBGoodProd == prod ->
 {-      || any (== FBGoodConsum) consum -}
       let
-       (use_args,big_args,args,body) = collectBinders expr'
+       (big_args,args,body) = collectBinders expr'
       in
        if length args /= length consum   -- funny number of arguments
        then returnWw [(id,expr')]
@@ -126,7 +123,7 @@ try_split_bind id expr =
        -- f_wrk /\ t1 .. tn t_new \ v1 .. vn c n -> foldr <exprTy> <nTy> c n e
        -- f /\ t1 .. tn \ v1 .. vn
        --      -> build exprTy (\ c n -> f_wrk t1 .. tn t_new v1 .. vn c n)
-       pprTrace "WW:" (ppr PprDebug id) (returnWw ())
+       pprTrace "WW:" (ppr id) (returnWw ())
                                `thenWw` \ () ->
        getUniqueWw             `thenWw` \ ty_new_uq ->
        getUniqueWw             `thenWw` \ worker_new_uq ->
@@ -148,17 +145,14 @@ try_split_bind id expr =
 
        worker_ty = mkForallTy (templ  ++ [alphaTyVar])
                        (foldr mkFunTy n_ty_templ (arg_tys++[c_ty_templ,n_ty_templ]))
-       wrapper_id  = id `replaceIdInfo`
-                             (getIdInfo id     `addInfo_UF`
-                              iWantToBeINLINEd UnfoldAlways)
+       wrapper_id  = setInlinePragma id IWantToBeINLINEd
        worker_id  = mkWorkerId worker_new_uq id worker_ty
-                               noIdInfo
                -- TODO : CHECK if mkWorkerId is thr
                -- right function to use ..
        -- Now the bodies
 
-       c_id = mkSysLocal SLIT("_fbww") c_new_uq c_ty mkUnknownSrcLoc
-       n_id = mkSysLocal SLIT("_fbww") n_new_uq n_ty mkUnknownSrcLoc
+       c_id = mkSysLocal SLIT("fbww") c_new_uq c_ty
+       n_id = mkSysLocal SLIT("fbww") n_new_uq n_ty
        worker_rhs
          = mkTyLam [] (big_args ++ [alphaTyVar]) (args++[c_id,n_id]) worker_body