[commit: ghc] wip/T12618: mkCoreConApp: Ensure let/app invariant (5b14d2a)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/T12618
Link       : http://ghc.haskell.org/trac/ghc/changeset/5b14d2a8d08eeca1ac74459c1b6872093536a133/ghc

>---------------------------------------------------------------

commit 5b14d2a8d08eeca1ac74459c1b6872093536a133
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Sat Oct 1 14:02:16 2016 -0400

    mkCoreConApp: Ensure let/app invariant
    
    This requires case-binding all affected arguments around the whole
    ConApp application, which is slightly more complicated than the App
    case. In particular, we need to juggle more than one unique. Therefore,
    I am adding another class of uniques.


>---------------------------------------------------------------

5b14d2a8d08eeca1ac74459c1b6872093536a133
 compiler/basicTypes/Unique.hs |  5 +++++
 compiler/coreSyn/MkCore.hs    | 27 ++++++++++++++++++++++++---
 compiler/prelude/PrelNames.hs | 17 ++++++++++++++---
 3 files changed, 43 insertions(+), 6 deletions(-)

diff --git a/compiler/basicTypes/Unique.hs b/compiler/basicTypes/Unique.hs
index c933d61..8d4a1d6 100644
--- a/compiler/basicTypes/Unique.hs
+++ b/compiler/basicTypes/Unique.hs
@@ -48,6 +48,7 @@ module Unique (
         mkPreludeMiscIdUnique, mkPreludeDataConUnique,
         mkPreludeTyConUnique, mkPreludeClassUnique,
         mkPArrDataConUnique, mkCoVarUnique,
+        mkCoreConAppUnique,
 
         mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique,
         mkRegSingleUnique, mkRegPairUnique, mkRegClassUnique, mkRegSubUnique,
@@ -322,6 +323,8 @@ Allocation of unique supply characters:
         n       Native codegen
         r       Hsc name cache
         s       simplifier
+        c       typechecker
+        a       binders for case expressions in mkCoreConApp (desugarer)
 -}
 
 mkAlphaTyVarUnique     :: Int -> Unique
@@ -335,10 +338,12 @@ mkPrimOpIdUnique       :: Int -> Unique
 mkPreludeMiscIdUnique  :: Int -> Unique
 mkPArrDataConUnique    :: Int -> Unique
 mkCoVarUnique          :: Int -> Unique
+mkCoreConAppUnique     :: Int -> Unique
 
 mkAlphaTyVarUnique   i = mkUnique '1' i
 mkCoVarUnique        i = mkUnique 'g' i
 mkPreludeClassUnique i = mkUnique '2' i
+mkCoreConAppUnique   i = mkUnique 'a' i
 
 --------------------------------------------------
 -- Wired-in type constructor keys occupy *two* slots:
diff --git a/compiler/coreSyn/MkCore.hs b/compiler/coreSyn/MkCore.hs
index 3861513..58f798c 100644
--- a/compiler/coreSyn/MkCore.hs
+++ b/compiler/coreSyn/MkCore.hs
@@ -152,12 +152,13 @@ mkCoreApps orig_fun orig_args
 mkCoreConApps :: DataCon -> [CoreExpr] -> CoreExpr
 mkCoreConApps con args
     | length args >= dataConRepFullArity con
-    = mkCoreApps (ConApp con conArgs) extraArgs
-    -- TODO #12618: Do we need to check needsCaseBinding?
+    = let sat_app = mk_val_apps 0 res_ty (ConApp con) con_args
+      in  mkCoreApps sat_app extra_args
   where
     -- TODO #12618: Can there ever be more than dataConRepArity con arguments
     -- in a type-safe program?
-    (conArgs, extraArgs) = splitAt (dataConRepFullArity con) args
+    (con_args, extra_args) = splitAt (dataConRepFullArity con) args
+    res_ty = exprType (ConApp con args)
 mkCoreConApps con args
     -- Unsaturated application. TODO #12618 Use wrapper.
     = mkCoreApps (Var (dataConWorkId con)) args
@@ -184,6 +185,26 @@ mk_val_app fun arg arg_ty res_ty
         -- is if you take apart this case expression, and pass a
         -- fragmet of it as the fun part of a 'mk_val_app'.
 
+mk_val_apps :: Int -> Type -> ([CoreExpr] -> CoreExpr) -> [CoreExpr] -> CoreExpr
+-- In the given list of expression, pick those that need a strict binding
+-- to ensure the let/app invariant, and wrap them accorindgly
+--   See Note [CoreSyn let/app invariant]
+mk_val_apps _ _ cont [] = cont []
+mk_val_apps n res_ty cont (Type ty:args)
+  = mk_val_apps n res_ty (cont . (Type ty:)) args
+mk_val_apps n res_ty cont (arg:args)
+  | not (needsCaseBinding arg_ty arg)
+  = mk_val_apps n res_ty (cont . (arg:)) args
+  | otherwise
+  = let body = mk_val_apps (n+1) res_ty (cont . (Var arg_id:)) args
+    in  Case arg arg_id res_ty [(DEFAULT, [], body)]
+  where
+    arg_ty = exprType arg  -- TODO # 12618 Do not use exprType here
+    arg_id = mkLocalIdOrCoVar (coreConAppUnique n) arg_ty
+        -- Lots of shadowing again. But that is ok, we have our own set of
+        -- uniques here, and they are only free inside this function
+
+
 -----------
 mkWildEvBinder :: PredType -> EvVar
 mkWildEvBinder pred = mkWildValBinder pred
diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs
index 558619a..d42314c 100644
--- a/compiler/prelude/PrelNames.hs
+++ b/compiler/prelude/PrelNames.hs
@@ -813,6 +813,20 @@ dataQual_RDR mod str = mkOrig mod (mkOccNameFS dataName str)
 {-
 ************************************************************************
 *                                                                      *
+\subsection{Internal names}
+*                                                                      *
+************************************************************************
+-}
+
+wildCardName :: Name
+wildCardName = mkSystemVarName wildCardKey (fsLit "wild")
+
+coreConAppUnique :: Int -> Name
+coreConAppUnique n = mkSystemVarName (mkCoreConAppUnique n) (fsLit "x")
+
+{-
+************************************************************************
+*                                                                      *
 \subsection{Known-key names}
 *                                                                      *
 ************************************************************************
@@ -825,9 +839,6 @@ and it's convenient to write them all down in one place.
 -- guys as well (perhaps) e.g. see  trueDataConName     below
 -}
 
-wildCardName :: Name
-wildCardName = mkSystemVarName wildCardKey (fsLit "wild")
-
 runMainIOName :: Name
 runMainIOName = varQual gHC_TOP_HANDLER (fsLit "runMainIO") runMainKey