[commit: ghc] wip/T9783: In pattern synonym matchers, support unboxed continuation results. (a4ea93c)

git at git.haskell.org git at git.haskell.org
Sat Nov 8 04:28:43 UTC 2014


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

On branch  : wip/T9783
Link       : http://ghc.haskell.org/trac/ghc/changeset/a4ea93cf55b0cbe893ce67b836be22b116b063a8/ghc

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

commit a4ea93cf55b0cbe893ce67b836be22b116b063a8
Author: Dr. ERDI Gergo <gergo at erdi.hu>
Date:   Sat Nov 8 12:24:55 2014 +0800

    In pattern synonym matchers, support unboxed continuation results.
    
    This requires ensuring the continuations have arguments by adding a dummy
    Void# argument when needed. This is so that matching on a pattern synonym
    is lazy even when the result is unboxed, e.g.
    
        pattern P = ()
        f P = 0#
    
    In this case, without dummy arguments, the generated matcher's type would be
    
       $mP :: forall (r :: ?). () -> r -> r -> r
    
    which is called in `f` at type `() -> Int# -> Int# -> Int#`,
    so it would be strict, in particular, in the failure continuation
    of `patError`.
    
    We work around this by making sure both continuations have arguments:
    
      $mP :: forall (r :: ?). () -> (Void# -> r) -> (Void# -> r) -> r
    
    Of course, if `P` (and thus, the success continuation) has any arguments,
    we are only adding the extra dummy argument to the failure continuation.


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

a4ea93cf55b0cbe893ce67b836be22b116b063a8
 compiler/basicTypes/PatSyn.lhs                     | 18 ++++++++++----
 compiler/deSugar/DsUtils.lhs                       |  4 +++-
 compiler/typecheck/TcPatSyn.lhs                    | 28 ++++++++++++----------
 testsuite/.gitignore                               |  1 +
 testsuite/tests/patsyn/should_run/T9783.hs         | 15 ++++++++++++
 .../tests/patsyn/should_run/T9783.stdout           |  2 +-
 testsuite/tests/patsyn/should_run/all.T            |  1 +
 7 files changed, 49 insertions(+), 20 deletions(-)

diff --git a/compiler/basicTypes/PatSyn.lhs b/compiler/basicTypes/PatSyn.lhs
index 2081b5a..1b78dac 100644
--- a/compiler/basicTypes/PatSyn.lhs
+++ b/compiler/basicTypes/PatSyn.lhs
@@ -130,11 +130,19 @@ data PatSyn
 
         -- See Note [Matchers and wrappers for pattern synonyms]
         psMatcher     :: Id,
-             -- Matcher function, of type
-             --   forall r univ_tvs. req_theta
-             --                   => res_ty
-             --                   -> (forall ex_tvs. prov_theta -> arg_tys -> r)
-             --                   -> r -> r
+            -- Matcher function. If psArgs is empty, then it has type
+             --   forall (r :: ?) univ_tvs. req_theta
+             --                       => res_ty
+             --                       -> (forall ex_tvs. prov_theta -> Void# -> r)
+             --                       -> (Void# -> r)
+             --                       -> r
+             --
+             -- Otherwise:
+             --   forall (r :: ?) univ_tvs. req_theta
+             --                       => res_ty
+             --                       -> (forall ex_tvs. prov_theta -> arg_tys -> r)
+             --                       -> (Void# -> r)
+             --                       -> r
 
         psWrapper     :: Maybe Id
              -- Nothing  => uni-directional pattern synonym
diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs
index a269374..d36e4c9 100644
--- a/compiler/deSugar/DsUtils.lhs
+++ b/compiler/deSugar/DsUtils.lhs
@@ -348,13 +348,15 @@ mkPatSynCase var ty alt fail = do
     matcher <- dsLExpr $ mkLHsWrap wrapper $ nlHsTyApp matcher [ty]
     let MatchResult _ mkCont = match_result
     cont <- mkCoreLams bndrs <$> mkCont fail
-    return $ mkCoreAppsDs matcher [Var var, cont, fail]
+    return $ mkCoreAppsDs matcher [Var var, ensure_unstrict cont, make_unstrict fail]
   where
     MkCaseAlt{ alt_pat = psyn,
                alt_bndrs = bndrs,
                alt_wrapper = wrapper,
                alt_result = match_result} = alt
     matcher = patSynMatcher psyn
+    ensure_unstrict = if null (patSynArgs psyn) then make_unstrict else id
+    make_unstrict = Lam voidArgId
 
 mkDataConCase :: Id -> Type -> [CaseAlt DataCon] -> MatchResult
 mkDataConCase _   _  []            = panic "mkDataConCase: no alternatives"
diff --git a/compiler/typecheck/TcPatSyn.lhs b/compiler/typecheck/TcPatSyn.lhs
index 9b2b511..2372a1b 100644
--- a/compiler/typecheck/TcPatSyn.lhs
+++ b/compiler/typecheck/TcPatSyn.lhs
@@ -24,12 +24,12 @@ import Outputable
 import FastString
 import Var
 import Id
-import IdInfo( IdDetails( VanillaId ) )
 import TcBinds
 import BasicTypes
 import TcSimplify
 import TcType
 import VarSet
+import MkId
 #if __GLASGOW_HASKELL__ < 709
 import Data.Monoid
 #endif
@@ -124,25 +124,29 @@ tcPatSynMatcher :: Located Name
                 -> TcM (Id, LHsBinds Id)
 -- See Note [Matchers and wrappers for pattern synonyms] in PatSyn
 tcPatSynMatcher (L loc name) lpat args univ_tvs ex_tvs ev_binds prov_dicts req_dicts prov_theta req_theta pat_ty
-  = do { res_tv <- zonkQuantifiedTyVar =<< newFlexiTyVar liftedTypeKind
+  = do { res_tv <- do
+              { uniq <- newUnique
+              ; let tv_name = mkInternalName uniq (mkTyVarOcc "r") loc
+              ; return $ mkTcTyVar tv_name openTypeKind (SkolemTv False) }
        ; matcher_name <- newImplicitBinder name mkMatcherOcc
        ; let res_ty = TyVarTy res_tv
+             cont_args = if null args then [voidPrimId] else args
              cont_ty = mkSigmaTy ex_tvs prov_theta $
-                       mkFunTys (map varType args) res_ty
+                       mkFunTys (map varType cont_args) res_ty
+             fail_ty = mkFunTy voidPrimTy res_ty
 
-       ; let matcher_tau = mkFunTys [pat_ty, cont_ty, res_ty] res_ty
+       ; let matcher_tau = mkFunTys [pat_ty, cont_ty, fail_ty] res_ty
              matcher_sigma = mkSigmaTy (res_tv:univ_tvs) req_theta matcher_tau
-             matcher_id = mkExportedLocalId VanillaId matcher_name matcher_sigma
+             matcher_id = mkVanillaGlobal matcher_name matcher_sigma
 
        ; traceTc "tcPatSynMatcher" (ppr name $$ ppr (idType matcher_id))
        ; let matcher_lid = L loc matcher_id
 
        ; scrutinee <- mkId "scrut" pat_ty
        ; cont <- mkId "cont" cont_ty
-       ; let cont' = nlHsApps cont $ map nlHsVar (ex_tvs ++ prov_dicts ++ args)
-       ; fail <- mkId "fail" res_ty
-       ; let fail' = nlHsVar fail
-
+       ; let cont' = nlHsApps cont $ map nlHsVar (ex_tvs ++ prov_dicts ++ cont_args)
+       ; fail <- mkId "fail" fail_ty
+       ; let fail' = nlHsApps fail [nlHsVar voidPrimId]
 
        ; let args = map nlVarPat [scrutinee, cont, fail]
              lwpat = noLoc $ WildPat pat_ty
@@ -185,9 +189,7 @@ tcPatSynMatcher (L loc name) lpat args univ_tvs ex_tvs ev_binds prov_dicts req_d
 
        ; return (matcher_id, matcher_bind) }
   where
-    mkId s ty = do
-        name <- newName . mkVarOccFS . fsLit $ s
-        return $ mkLocalId name ty
+    mkId s ty = mkSysLocalM (fsLit s) ty
 
 isBidirectional :: HsPatSynDir a -> Bool
 isBidirectional Unidirectional = False
@@ -243,7 +245,7 @@ mkPatSynWrapperId (L _ name) args univ_tvs ex_tvs theta pat_ty
              wrapper_sigma = mkSigmaTy wrapper_tvs wrapper_theta wrapper_tau
 
        ; wrapper_name <- newImplicitBinder name mkDataConWrapperOcc
-       ; return $ mkExportedLocalId VanillaId wrapper_name wrapper_sigma }
+       ; return $ mkVanillaGlobal wrapper_name wrapper_sigma }
 
 mkPatSynWrapper :: Id
                 -> HsBind Name
diff --git a/testsuite/.gitignore b/testsuite/.gitignore
index ce5c2c2..2423e15 100644
--- a/testsuite/.gitignore
+++ b/testsuite/.gitignore
@@ -1097,6 +1097,7 @@ mk/ghcconfig*_inplace_bin_ghc-stage2.exe.mk
 /tests/patsyn/should_run/ex-prov
 /tests/patsyn/should_run/ex-prov-run
 /tests/patsyn/should_run/match
+/tests/patsyn/should_run/match-unboxed
 /tests/perf/compiler/T1969.comp.stats
 /tests/perf/compiler/T3064.comp.stats
 /tests/perf/compiler/T3294.comp.stats
diff --git a/testsuite/tests/patsyn/should_run/T9783.hs b/testsuite/tests/patsyn/should_run/T9783.hs
new file mode 100644
index 0000000..daef960
--- /dev/null
+++ b/testsuite/tests/patsyn/should_run/T9783.hs
@@ -0,0 +1,15 @@
+{-# LANGUAGE PatternSynonyms, MagicHash #-}
+module Main where
+
+import GHC.Base
+
+pattern P1 <- 0
+pattern P2 <- 1
+
+f :: Int -> Int#
+f P1 = 42#
+f P2 = 44#
+
+main = do
+    print $ I# (f 0)
+    print $ I# (f 1)
diff --git a/libraries/base/tests/IO/hGetChar001.stdin b/testsuite/tests/patsyn/should_run/T9783.stdout
similarity index 50%
copy from libraries/base/tests/IO/hGetChar001.stdin
copy to testsuite/tests/patsyn/should_run/T9783.stdout
index 2510fca..c26b130 100644
--- a/libraries/base/tests/IO/hGetChar001.stdin
+++ b/testsuite/tests/patsyn/should_run/T9783.stdout
@@ -1,2 +1,2 @@
 42
--7
+44
diff --git a/testsuite/tests/patsyn/should_run/all.T b/testsuite/tests/patsyn/should_run/all.T
index b3c6b74..9c3f16b 100644
--- a/testsuite/tests/patsyn/should_run/all.T
+++ b/testsuite/tests/patsyn/should_run/all.T
@@ -3,3 +3,4 @@ test('match', normal, compile_and_run, [''])
 test('ex-prov-run', normal, compile_and_run, [''])
 test('bidir-explicit', normal, compile_and_run, [''])
 test('bidir-explicit-scope', normal, compile_and_run, [''])
+test('T9783', normal, compile_and_run, [''])



More information about the ghc-commits mailing list