[commit: ghc] wip/T12618: Actually desugar to ConApp (2ff3c49)

[git at git.haskell.org]

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

On branch  : wip/T12618
Link       : http://ghc.haskell.org/trac/ghc/changeset/2ff3c49ecbd2c6bcdc34a3965c908204caa53dbb/ghc

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

commit 2ff3c49ecbd2c6bcdc34a3965c908204caa53dbb
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Fri Sep 30 20:50:42 2016 -0400

    Actually desugar to ConApp
    
    at least if the constructor is saturated. Fall back to the worker
    otherwise.


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

2ff3c49ecbd2c6bcdc34a3965c908204caa53dbb
 compiler/basicTypes/Unique.hs |  5 +++++
 compiler/coreSyn/MkCore.hs    | 35 +++++++++++++++++++++++++++++++++--
 compiler/prelude/PrelNames.hs | 17 ++++++++++++++---
 3 files changed, 52 insertions(+), 5 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 e7fc7f9..58f798c 100644
--- a/compiler/coreSyn/MkCore.hs
+++ b/compiler/coreSyn/MkCore.hs
@@ -67,7 +67,7 @@ import TcType           ( mkSpecSigmaTy )
 import Type
 import Coercion         ( isCoVar )
 import TysPrim
-import DataCon          ( DataCon, dataConWorkId )
+import DataCon          ( DataCon, dataConRepFullArity, dataConWorkId )
 import IdInfo           ( vanillaIdInfo, setStrictnessInfo,
                           setArityInfo )
 import Demand
@@ -150,7 +150,18 @@ mkCoreApps orig_fun orig_args
 -- expressions to that of a data constructor expression. The leftmost expression
 -- in the list is applied first
 mkCoreConApps :: DataCon -> [CoreExpr] -> CoreExpr
-mkCoreConApps con args = mkCoreApps (Var (dataConWorkId con)) args
+mkCoreConApps con args
+    | length args >= dataConRepFullArity con
+    = 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?
+    (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
 
 mk_val_app :: CoreExpr -> CoreExpr -> Type -> Type -> CoreExpr
 -- Build an application (e1 e2),
@@ -174,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