Refactor TcRnDriver, and check exports on hi-boot files

[ghc-hetmet.git] / compiler / deSugar / DsUtils.lhs

diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs
index 0552c2b..71a8320 100644 (file)
--- a/compiler/deSugar/DsUtils.lhs
+++ b/compiler/deSugar/DsUtils.lhs
@@ -12,7 +12,7 @@ module DsUtils (
        EquationInfo(..), 
        firstPat, shiftEqns,
        
-       mkDsLet, mkDsLets,
+       mkDsLet, mkDsLets, mkDsApp, mkDsApps,
 
        MatchResult(..), CanItFail(..), 
        cantFailMatchResult, alwaysFailMatchResult,
@@ -33,7 +33,8 @@ module DsUtils (
        
        dsSyntaxTable, lookupEvidence,
 
-       selectSimpleMatchVarL, selectMatchVars, selectMatchVar
+       selectSimpleMatchVarL, selectMatchVars, selectMatchVar,
+       mkTickBox, mkOptTickBox, mkBinaryTickBox
     ) where
 
 #include "HsVersions.h"
@@ -69,10 +70,13 @@ import Util
 import ListSetOps
 import FastString
 import Data.Char
+import DynFlags
 
 #ifdef DEBUG
 import Util
 #endif
+
+infixl 4 `mkDsApp`, `mkDsApps`
 \end{code}
 
 
@@ -120,13 +124,43 @@ back again.
 \begin{code}
 mkDsLet :: CoreBind -> CoreExpr -> CoreExpr
 mkDsLet (NonRec bndr rhs) body
-  | isUnLiftedType (idType bndr) 
+  | isUnLiftedType (idType bndr) && not (exprOkForSpeculation rhs)
   = Case rhs bndr (exprType body) [(DEFAULT,[],body)]
 mkDsLet bind body
   = Let bind body
 
 mkDsLets :: [CoreBind] -> CoreExpr -> CoreExpr
 mkDsLets binds body = foldr mkDsLet body binds
+
+-----------
+mkDsApp :: CoreExpr -> CoreExpr -> CoreExpr
+-- Check the invariant that the arg of an App is ok-for-speculation if unlifted
+-- See CoreSyn Note [CoreSyn let/app invariant]
+mkDsApp fun (Type ty) = App fun (Type ty)
+mkDsApp fun arg       = mk_val_app fun arg arg_ty res_ty
+                     where
+                       (arg_ty, res_ty) = splitFunTy (exprType fun)
+
+-----------
+mkDsApps :: CoreExpr -> [CoreExpr] -> CoreExpr
+-- Slightly more efficient version of (foldl mkDsApp)
+mkDsApps fun args
+  = go fun (exprType fun) args
+  where
+    go fun fun_ty []               = fun
+    go fun fun_ty (Type ty : args) = go (App fun (Type ty)) (applyTy fun_ty ty) args
+    go fun fun_ty (arg     : args) = go (mk_val_app fun arg arg_ty res_ty) res_ty args
+                                  where
+                                    (arg_ty, res_ty) = splitFunTy fun_ty
+-----------
+mk_val_app fun arg arg_ty res_ty
+  | isUnLiftedType arg_ty && not (exprOkForSpeculation arg)
+  = Case arg arg_id res_ty [(DEFAULT,[],App fun (Var arg_id))]
+  | otherwise          -- The common case
+  = App fun arg
+  where
+    arg_id = mkWildId arg_ty   -- Lots of shadowing, but it doesn't matter,
+                               -- because 'fun ' should not have a free wild-id
 \end{code}
 
 
@@ -805,7 +839,6 @@ mkCoreSel vars the_var scrut_var scrut
         [(DataAlt (tupleCon Boxed (length vars)), vars, Var the_var)]
 \end{code}
 
-
 %************************************************************************
 %*                                                                     *
 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
@@ -880,4 +913,37 @@ mkFailurePair expr
     ty = exprType expr
 \end{code}
 
-
+\begin{code}
+mkOptTickBox :: Maybe Int -> CoreExpr -> DsM CoreExpr
+mkOptTickBox Nothing e   = return e
+mkOptTickBox (Just ix) e = mkTickBox ix e
+
+mkTickBox :: Int -> CoreExpr -> DsM CoreExpr
+mkTickBox ix e = do
+       uq <- newUnique         
+       mod <- getModuleDs
+       let tick = mkTickBoxOpId uq mod ix
+       uq2 <- newUnique        
+       let occName = mkVarOcc "tick"
+       let name = mkInternalName uq2 occName noSrcLoc   -- use mkSysLocal?
+       let var  = Id.mkLocalId name realWorldStatePrimTy
+       return $ Case (Var tick) 
+                    var
+                    ty
+                    [(DEFAULT,[],e)]
+  where
+     ty = exprType e
+
+mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr
+mkBinaryTickBox ixT ixF e = do
+       mod <- getModuleDs
+       uq <- newUnique         
+       mod <- getModuleDs
+       let bndr1 = mkSysLocal FSLIT("t1") uq boolTy 
+       falseBox <- mkTickBox ixF $ Var falseDataConId
+       trueBox  <- mkTickBox ixT $ Var trueDataConId
+       return $ Case e bndr1 boolTy
+                       [ (DataAlt falseDataCon, [], falseBox)
+                       , (DataAlt trueDataCon,  [], trueBox)
+                       ]
+\end{code}
\ No newline at end of file