[commit: ghc] wip/T12618: Actually desugar to ConApp (a7b2939)
git at git.haskell.org
git at git.haskell.org
Mon Oct 3 01:20:00 UTC 2016
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/T12618
Link : http://ghc.haskell.org/trac/ghc/changeset/a7b29397fe04f628df39fb670c48b7b13c4cfaab/ghc
>---------------------------------------------------------------
commit a7b29397fe04f628df39fb670c48b7b13c4cfaab
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.
>---------------------------------------------------------------
a7b29397fe04f628df39fb670c48b7b13c4cfaab
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
More information about the ghc-commits
mailing list