Rationalise GhcMode, HscTarget and GhcLink

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

diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs
index 6bc70e2..455db04 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,
@@ -70,11 +70,8 @@ import Util
 import ListSetOps
 import FastString
 import Data.Char
-import DynFlags
 
-#ifdef DEBUG
-import Util
-#endif
+infixl 4 `mkDsApp`, `mkDsApps`
 \end{code}
 
 
@@ -121,16 +118,71 @@ back again.
 
 \begin{code}
 mkDsLet :: CoreBind -> CoreExpr -> CoreExpr
-mkDsLet (NonRec bndr rhs) body
-  | isUnLiftedType (idType bndr) 
+mkDsLet (NonRec bndr rhs) body -- See Note [CoreSyn let/app invariant]
+  | 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       -- See Note [CoreSyn let/app invariant]
+  | not (isUnLiftedType arg_ty) || exprOkForSpeculation arg
+  = App fun arg                -- The vastly common case
+
+mk_val_app (Var f `App` Type ty1 `App` Type ty2 `App` arg1) arg2 _ res_ty
+  | f == seqId         -- Note [Desugaring seq]
+  = Case arg1 (mkWildId ty1) res_ty [(DEFAULT,[],arg2)]
+
+mk_val_app fun arg arg_ty res_ty
+  = Case arg (mkWildId arg_ty) res_ty [(DEFAULT,[],App fun (Var arg_id))]
+  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}
 
+Note [Desugaring seq]  cf Trac #1031
+~~~~~~~~~~~~~~~~~~~~~
+   f x y = x `seq` (y `seq` (# x,y #))
+
+The [CoreSyn let/app invariant] means that, other things being equal, because 
+the argument to the outer 'seq' has an unlifted type, we'll use call-by-value thus:
+
+   f x y = case (y `seq` (# x,y #)) of v -> x `seq` v
+
+But that is bad for two reasons: 
+  (a) we now evaluate y before x, and 
+  (b) we can't bind v to an unboxed pair
+
+Seq is very, very special!  So we recognise it right here, and desugar to
+       case x of _ -> case y of _ -> (# x,y #)
+
+The special case would be valid for all calls to 'seq', but it's only *necessary*
+for ones whose second argument has an unlifted type. So we only catch the latter
+case here, to avoid unnecessary tests.
+
 
 %************************************************************************
 %*                                                                     *
@@ -807,7 +859,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}
@@ -889,7 +940,6 @@ mkOptTickBox (Just ix) e = mkTickBox ix e
 
 mkTickBox :: Int -> CoreExpr -> DsM CoreExpr
 mkTickBox ix e = do
-       dflags <- getDOptsDs
        uq <- newUnique         
        mod <- getModuleDs
        let tick = mkTickBoxOpId uq mod ix
@@ -907,9 +957,13 @@ mkTickBox ix e = do
 mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr
 mkBinaryTickBox ixT ixF e = do
        mod <- getModuleDs
-       dflags <- getDOptsDs
        uq <- newUnique         
        mod <- getModuleDs
-       let tick = mkBinaryTickBoxOpId uq mod ixT ixF
-       return $ App (Var tick) e
+       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