If pattern synonym is bidirectional and its type is some unboxed type T#,

generate a worker function of type Void# -> T#, and redirect the wrapper
(via a compulsory unfolding) to the worker. Fixes #9732.

20 files changed, 228 insertions, 87 deletions

diff --git a/compiler/basicTypes/PatSyn.lhs b/compiler/basicTypes/PatSyn.lhs
index 89c4374388..c651080244 100644
--- a/compiler/basicTypes/PatSyn.lhs
+++ b/compiler/basicTypes/PatSyn.lhs
@@ -14,7 +14,8 @@ module PatSyn (
         -- ** Type deconstruction
         patSynName, patSynArity, patSynIsInfix,
         patSynArgs, patSynTyDetails, patSynType,
-        patSynWrapper, patSynMatcher,
+        patSynMatcher,
+        patSynWrapper, patSynWorker,
         patSynExTyVars, patSynSig,
         patSynInstArgTys, patSynInstResTy,
         tidyPatSynIds
@@ -36,6 +37,7 @@ import HsBinds( HsPatSynDetails(..) )
 import qualified Data.Data as Data
 import qualified Data.Typeable
 import Data.Function
+import Control.Arrow (second)
 \end{code}
 
 
@@ -109,6 +111,37 @@ Injectivity of bidirectional pattern synonyms is checked in
 tcPatToExpr which walks the pattern and returns its corresponding
 expression when available.
 
+Note [Wrapper/worker for pattern synonyms with unboxed type]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+For bidirectional pattern synonyms that have no arguments and have
+an unboxed type, we add an extra level of indirection, since $WP would
+otherwise be a top-level declaration with an unboxed type. In this case,
+a separate worker function is generated that has an extra Void# argument,
+and the wrapper redirects to it via a compulsory unfolding (that just
+applies it on Void#). Example:
+
+        pattern P = 0#
+
+        $WP :: Int#
+        $WP unfolded to ($wP Void#)
+
+        $wP :: Void# -> Int#
+        $wP _ = 0#
+
+To make things more uniform, we always store two `Id`s in `PatSyn` for
+the wrapper and the worker, with the following behaviour:
+
+  if `psWrapper` == Just (`wrapper`, `worker`), then
+
+  * `wrapper` should always be used when compiling the pattern synonym
+    in an expression context (and its type is as prescribed)
+  * `worker` is always an `Id` with a binding that needs to be exported
+    as part of the definition of the pattern synonym
+
+If a separate worker is not needed (because the pattern synonym has arguments
+or has a non-unboxed type), the two `Id`s are the same.
+
 %************************************************************************
 %*                                                                      *
 \subsection{Pattern synonyms}
@@ -149,12 +182,14 @@ data PatSyn
              --                       -> (Void# -> r)
              --                       -> r
 
-        psWrapper     :: Maybe Id
+        psWrapper     :: Maybe (Id, Id)
              -- Nothing  => uni-directional pattern synonym
-             -- Just wid => bi-direcitonal
+             -- Just (wrapper, worker) => bi-direcitonal
              -- Wrapper function, of type
              --  forall univ_tvs, ex_tvs. (prov_theta, req_theta)
              --                       =>  arg_tys -> res_ty
+             --
+             -- See Note [Wrapper/worker for pattern synonyms with unboxed type]
   }
   deriving Data.Typeable.Typeable
 \end{code}
@@ -215,7 +250,7 @@ mkPatSyn :: Name
          -> [Type]               -- ^ Original arguments
          -> Type                 -- ^ Original result type
          -> Id                   -- ^ Name of matcher
-         -> Maybe Id             -- ^ Name of wrapper
+         -> Maybe (Id, Id)       -- ^ Name of wrapper/worker
          -> PatSyn
 mkPatSyn name declared_infix
          (univ_tvs, req_theta)
@@ -276,14 +311,17 @@ patSynSig (MkPatSyn { psUnivTyVars = univ_tvs, psExTyVars = ex_tvs
   = (univ_tvs, ex_tvs, prov, req, arg_tys, res_ty)
 
 patSynWrapper :: PatSyn -> Maybe Id
-patSynWrapper = psWrapper
+patSynWrapper = fmap fst . psWrapper
+
+patSynWorker :: PatSyn -> Maybe Id
+patSynWorker = fmap snd . psWrapper
 
 patSynMatcher :: PatSyn -> Id
 patSynMatcher = psMatcher
 
 tidyPatSynIds :: (Id -> Id) -> PatSyn -> PatSyn
 tidyPatSynIds tidy_fn ps@(MkPatSyn { psMatcher = match_id, psWrapper = mb_wrap_id })
-  = ps { psMatcher = tidy_fn match_id, psWrapper = fmap tidy_fn mb_wrap_id }
+  = ps { psMatcher = tidy_fn match_id, psWrapper = fmap (second tidy_fn) mb_wrap_id }
 
 patSynInstArgTys :: PatSyn -> [Type] -> [Type]
 -- Return the types of the argument patterns
diff --git a/compiler/ghc.mk b/compiler/ghc.mk
index 46773d840f..fb8aa730e8 100644
--- a/compiler/ghc.mk
+++ b/compiler/ghc.mk
@@ -574,6 +574,7 @@ compiler_stage2_dll0_MODULES = \
 	StringBuffer \
 	TcEvidence \
 	TcIface \
+	TcMType \
 	TcRnMonad \
 	TcRnTypes \
 	TcType \
diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs
index d90e63c972..106a15fc9a 100644
--- a/compiler/iface/BuildTyCl.lhs
+++ b/compiler/iface/BuildTyCl.lhs
@@ -179,7 +179,7 @@ mkDataConStupidTheta tycon arg_tys univ_tvs
 
 ------------------------------------------------------
 buildPatSyn :: Name -> Bool
-            -> Id -> Maybe Id
+            -> Id -> Maybe (Id, Id)
             -> ([TyVar], ThetaType) -- ^ Univ and req
             -> ([TyVar], ThetaType) -- ^ Ex and prov
             -> [Type]               -- ^ Argument types
diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs
index 5cfe773dc8..c2b7c5276b 100644
--- a/compiler/iface/IfaceSyn.lhs
+++ b/compiler/iface/IfaceSyn.lhs
@@ -128,7 +128,7 @@ data IfaceDecl
   | IfacePatSyn { ifName          :: IfaceTopBndr,           -- Name of the pattern synonym
                   ifPatIsInfix    :: Bool,
                   ifPatMatcher    :: IfExtName,
-                  ifPatWrapper    :: Maybe IfExtName,
+                  ifPatWorker     :: Maybe IfExtName,
                   -- Everything below is redundant,
                   -- but needed to implement pprIfaceDecl
                   ifPatUnivTvs    :: [IfaceTvBndr],
@@ -759,15 +759,15 @@ pprIfaceDecl ss (IfaceSyn { ifName = tycon, ifTyVars = tyvars
         $$ ppShowIface ss (ptext (sLit "axiom") <+> ppr ax)
     pp_branches _ = Outputable.empty
 
-pprIfaceDecl _ (IfacePatSyn { ifName = name, ifPatWrapper = wrapper,
+pprIfaceDecl _ (IfacePatSyn { ifName = name, ifPatWorker = worker,
                               ifPatIsInfix = is_infix,
                               ifPatUnivTvs = _univ_tvs, ifPatExTvs = _ex_tvs,
                               ifPatProvCtxt = prov_ctxt, ifPatReqCtxt = req_ctxt,
                               ifPatArgs = args,
                               ifPatTy = ty })
-  = pprPatSynSig name has_wrap args' ty' (pprCtxt prov_ctxt) (pprCtxt req_ctxt)
+  = pprPatSynSig name is_bidirectional args' ty' (pprCtxt prov_ctxt) (pprCtxt req_ctxt)
   where
-    has_wrap = isJust wrapper
+    is_bidirectional = isJust worker
     args' = case (is_infix, args) of
         (True, [left_ty, right_ty]) ->
             InfixPatSyn (pprParendIfaceType left_ty) (pprParendIfaceType right_ty)
@@ -1131,7 +1131,7 @@ freeNamesIfDecl d@IfaceAxiom{} =
   fnList freeNamesIfAxBranch (ifAxBranches d)
 freeNamesIfDecl d@IfacePatSyn{} =
   unitNameSet (ifPatMatcher d) &&&
-  maybe emptyNameSet unitNameSet (ifPatWrapper d) &&&
+  maybe emptyNameSet unitNameSet (ifPatWorker d) &&&
   freeNamesIfTvBndrs (ifPatUnivTvs d) &&&
   freeNamesIfTvBndrs (ifPatExTvs d) &&&
   freeNamesIfContext (ifPatProvCtxt d) &&&
diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index 78111b299e..95fe479447 100644
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -1534,7 +1534,7 @@ patSynToIfaceDecl :: PatSyn -> IfaceDecl
 patSynToIfaceDecl ps
   = IfacePatSyn { ifName          = getOccName . getName $ ps
                 , ifPatMatcher    = matcher
-                , ifPatWrapper    = wrapper
+                , ifPatWorker     = worker
                 , ifPatIsInfix    = patSynIsInfix ps
                 , ifPatUnivTvs    = toIfaceTvBndrs univ_tvs'
                 , ifPatExTvs      = toIfaceTvBndrs ex_tvs'
@@ -1549,7 +1549,7 @@ patSynToIfaceDecl ps
     (env2, ex_tvs')   = tidyTyVarBndrs env1 ex_tvs
 
     matcher = idName (patSynMatcher ps)
-    wrapper = fmap idName (patSynWrapper ps)
+    worker = fmap idName (patSynWorker ps)
 
 
 --------------------------
diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index 65345ec3c8..cabf311382 100644
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -14,7 +14,8 @@ module TcIface (
         tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules,
         tcIfaceVectInfo, tcIfaceAnnotations,
         tcIfaceExpr,    -- Desired by HERMIT (Trac #7683)
-        tcIfaceGlobal
+        tcIfaceGlobal,
+        mkPatSynWrapperId, mkPatSynWorkerId -- Have to be here to avoid circular import
  ) where
 
 #include "HsVersions.h"
@@ -27,7 +28,8 @@ import BuildTyCl
 import TcRnMonad
 import TcType
 import Type
-import Coercion
+import TcMType
+import Coercion hiding (substTy)
 import TypeRep
 import HscTypes
 import Annotations
@@ -37,7 +39,7 @@ import CoreSyn
 import CoreUtils
 import CoreUnfold
 import CoreLint
-import MkCore                       ( castBottomExpr )
+import MkCore
 import Id
 import MkId
 import IdInfo
@@ -75,6 +77,7 @@ import qualified Data.Map as Map
 #if __GLASGOW_HASKELL__ < 709
 import Data.Traversable ( traverse )
 #endif
+import Data.Traversable ( for )
 \end{code}
 
 This module takes
@@ -582,7 +585,7 @@ tc_iface_decl _ _ (IfaceAxiom { ifName = ax_occ, ifTyCon = tc
 
 tc_iface_decl _ _ (IfacePatSyn{ ifName = occ_name
                               , ifPatMatcher = matcher_name
-                              , ifPatWrapper = wrapper_name
+                              , ifPatWorker = worker_name
                               , ifPatIsInfix = is_infix
                               , ifPatUnivTvs = univ_tvs
                               , ifPatExTvs = ex_tvs
@@ -593,10 +596,7 @@ tc_iface_decl _ _ (IfacePatSyn{ ifName = occ_name
   = do { name <- lookupIfaceTop occ_name
        ; traceIf (ptext (sLit "tc_iface_decl") <+> ppr name)
        ; matcher <- tcExt "Matcher" matcher_name
-       ; wrapper <- case wrapper_name of
-                        Nothing -> return Nothing
-                        Just wn -> do { wid <- tcExt "Wrapper" wn
-                                      ; return (Just wid) }
+       ; worker <- traverse (tcExt "Worker") worker_name
        ; bindIfaceTyVars univ_tvs $ \univ_tvs -> do
        { bindIfaceTyVars ex_tvs $ \ex_tvs -> do
        { patsyn <- forkM (mk_doc name) $
@@ -604,6 +604,14 @@ tc_iface_decl _ _ (IfacePatSyn{ ifName = occ_name
                 ; req_theta  <- tcIfaceCtxt req_ctxt
                 ; pat_ty     <- tcIfaceType pat_ty
                 ; arg_tys    <- mapM tcIfaceType args
+                ; wrapper    <- for worker $ \worker_id -> do
+                    { wrapper_id <- mkPatSynWrapperId (noLoc name)
+                                      (univ_tvs ++ ex_tvs)
+                                      (req_theta ++ prov_theta)
+                                      arg_tys pat_ty
+                                      worker_id
+                    ; return (wrapper_id, worker_id)
+                    }
                 ; return $ buildPatSyn name is_infix matcher wrapper
                                        (univ_tvs, req_theta) (ex_tvs, prov_theta)
                                        arg_tys pat_ty }
@@ -1520,3 +1528,41 @@ bindIfaceTyVars_AT (b@(tv_occ,_) : bs) thing_inside
          bindIfaceTyVars_AT bs $ \bs' ->
          thing_inside (b':bs') }
 \end{code}
+
+%************************************************************************
+%*                                                                      *
+                PatSyn wrapper/worker helpers
+%*                                                                      *
+%************************************************************************
+
+\begin{code}
+-- These are here (and not in TcPatSyn) just to avoid circular imports.
+
+mkPatSynWrapperId :: Located Name
+                  -> [TyVar] -> ThetaType -> [Type] -> Type
+                  -> Id
+                  -> TcRnIf gbl lcl Id
+mkPatSynWrapperId name qtvs theta arg_tys pat_ty worker_id
+  | need_dummy_arg = do
+      { wrapper_id <- mkPatSynWorkerId name mkDataConWrapperOcc qtvs theta arg_tys pat_ty
+      ; let unfolding = mkCoreApp (Var worker_id) (Var voidPrimId)
+            wrapper_id' = setIdUnfolding wrapper_id $ mkCompulsoryUnfolding unfolding
+      ; return wrapper_id' }
+  | otherwise = return worker_id -- No indirection needed
+  where
+    need_dummy_arg = null arg_tys && isUnLiftedType pat_ty
+
+mkPatSynWorkerId :: Located Name -> (OccName -> OccName)
+                 -> [TyVar] -> ThetaType -> [Type] -> Type
+                 -> TcRnIf gbl loc Id
+mkPatSynWorkerId (L loc name) mk_occ_name qtvs theta arg_tys pat_ty
+  = do { worker_name <- newImplicitBinder name mk_occ_name
+       ; (subst, worker_tvs) <- tcInstSigTyVarsLoc loc qtvs
+       ; let worker_theta = substTheta subst theta
+             pat_ty' = substTy subst pat_ty
+             arg_tys' = map (substTy subst) arg_tys
+             worker_tau = mkFunTys arg_tys' pat_ty'
+             -- TODO: just substitute worker_sigma...
+             worker_sigma = mkSigmaTy worker_tvs worker_theta worker_tau
+       ; return $ mkVanillaGlobal worker_name worker_sigma }
+\end{code}
diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs
index 8aed1657be..c2af40703d 100644
--- a/compiler/typecheck/TcBinds.lhs
+++ b/compiler/typecheck/TcBinds.lhs
@@ -16,7 +16,7 @@ module TcBinds ( tcLocalBinds, tcTopBinds, tcRecSelBinds,
 
 import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun )
 import {-# SOURCE #-} TcExpr  ( tcMonoExpr )
-import {-# SOURCE #-} TcPatSyn ( tcPatSynDecl, tcPatSynWrapper )
+import {-# SOURCE #-} TcPatSyn ( tcPatSynDecl, tcPatSynWorker )
 
 import DynFlags
 import HsSyn
@@ -320,8 +320,8 @@ tcValBinds top_lvl binds sigs thing_inside
             { (binds', (extra_binds', thing)) <- tcBindGroups top_lvl sig_fn prag_fn binds $ do
                    { thing <- thing_inside
                      -- See Note [Pattern synonym wrappers don't yield dependencies]
-                   ; patsyn_wrappers <- mapM tcPatSynWrapper patsyns
-                   ; let extra_binds = [ (NonRecursive, wrapper) | wrapper <- patsyn_wrappers ]
+                   ; patsyn_workers <- mapM tcPatSynWorker patsyns
+                   ; let extra_binds = [ (NonRecursive, worker) | worker <- patsyn_workers ]
                    ; return (extra_binds, thing) }
              ; return (binds' ++ extra_binds', thing) }}
   where
@@ -424,7 +424,7 @@ tc_single _top_lvl _sig_fn _prag_fn (L _ (PatSynBind psb)) thing_inside
 
        ; let tything = AConLike (PatSynCon pat_syn)
              implicit_ids = (patSynMatcher pat_syn) :
-                            (maybeToList (patSynWrapper pat_syn))
+                            (maybeToList (patSynWorker pat_syn))
 
        ; thing <- tcExtendGlobalEnv [tything] $
                   tcExtendGlobalEnvImplicit (map AnId implicit_ids) $
diff --git a/compiler/typecheck/TcPatSyn.lhs b/compiler/typecheck/TcPatSyn.lhs
index ea2dbce9d7..8ba69fdab4 100644
--- a/compiler/typecheck/TcPatSyn.lhs
+++ b/compiler/typecheck/TcPatSyn.lhs
@@ -7,13 +7,14 @@
 \begin{code}
 {-# LANGUAGE CPP #-}
 
-module TcPatSyn (tcPatSynDecl, tcPatSynWrapper) where
+module TcPatSyn (tcPatSynDecl, mkPatSynWrapperId, tcPatSynWorker) where
 
 import HsSyn
 import TcPat
 import TcRnMonad
 import TcEnv
 import TcMType
+import TcIface
 import TysPrim
 import Name
 import SrcLoc
@@ -37,6 +38,7 @@ import Bag
 import TcEvidence
 import BuildTyCl
 import TypeRep
+import Data.Maybe
 
 #include "HsVersions.h"
 \end{code}
@@ -48,7 +50,6 @@ tcPatSynDecl PSB{ psb_id = lname@(L _ name), psb_args = details,
                   psb_def = lpat, psb_dir = dir }
   = do { traceTc "tcPatSynDecl {" $ ppr name $$ ppr lpat
        ; tcCheckPatSynPat lpat
-       ; 
 
        ; let (arg_names, is_infix) = case details of
                  PrefixPatSyn names      -> (map unLoc names, False)
@@ -78,6 +79,7 @@ tcPatSynDecl PSB{ psb_id = lname@(L _ name), psb_args = details,
        ; req_theta  <- zonkTcThetaType req_theta
        ; pat_ty     <- zonkTcType pat_ty
        ; args       <- mapM zonkId args
+       ; let arg_tys = map varType args
 
        ; traceTc "tcPatSynDecl: ex" (ppr ex_tvs $$
                                      ppr prov_theta $$
@@ -87,7 +89,8 @@ tcPatSynDecl PSB{ psb_id = lname@(L _ name), psb_args = details,
                                        ppr req_dicts $$
                                        ppr ev_binds)
 
-       ; let theta = prov_theta ++ req_theta
+       ; let qtvs = univ_tvs ++ ex_tvs
+       ; let theta = req_theta ++ prov_theta
 
        ; traceTc "tcPatSynDecl: type" (ppr name $$
                                        ppr univ_tvs $$
@@ -101,17 +104,19 @@ tcPatSynDecl PSB{ psb_id = lname@(L _ name), psb_args = details,
                                          prov_theta req_theta
                                          pat_ty
 
-       ; wrapper_id <- if isBidirectional dir
-                       then fmap Just $ mkPatSynWrapperId lname args univ_tvs ex_tvs theta pat_ty
-                       else return Nothing
+       ; wrapper_ids <- if isBidirectional dir
+                        then fmap Just $ mkPatSynWrapperIds lname
+                                           qtvs theta
+                                           arg_tys pat_ty
+                        else return Nothing
 
        ; traceTc "tcPatSynDecl }" $ ppr name
        ; let patSyn = mkPatSyn name is_infix
                         (univ_tvs, req_theta)
                         (ex_tvs, prov_theta)
-                        (map varType args)
+                        arg_tys
                         pat_ty
-                        matcher_id wrapper_id
+                        matcher_id wrapper_ids
        ; return (patSyn, matcher_bind) }
 
 \end{code}
@@ -201,73 +206,69 @@ isBidirectional Unidirectional = False
 isBidirectional ImplicitBidirectional = True
 isBidirectional ExplicitBidirectional{} = True
 
-tcPatSynWrapper :: PatSynBind Name Name
+tcPatSynWorker :: PatSynBind Name Name
                 -> TcM (LHsBinds Id)
 -- See Note [Matchers and wrappers for pattern synonyms] in PatSyn
-tcPatSynWrapper PSB{ psb_id = L loc name, psb_def = lpat, psb_dir = dir, psb_args = details }
+tcPatSynWorker PSB{ psb_id = lname, psb_def = lpat, psb_dir = dir, psb_args = details }
   = case dir of
     Unidirectional -> return emptyBag
     ImplicitBidirectional ->
-        do { wrapper_id <- tcLookupPatSynWrapper name
-           ; lexpr <- case tcPatToExpr (mkNameSet args) lpat of
+        do { lexpr <- case tcPatToExpr (mkNameSet args) lpat of
                   Nothing -> cannotInvertPatSynErr lpat
                   Just lexpr -> return lexpr
            ; let wrapper_args = map (noLoc . VarPat) args
-                 wrapper_lname = L (getLoc lpat) (idName wrapper_id)
                  wrapper_match = mkMatch wrapper_args lexpr EmptyLocalBinds
-                 wrapper_bind = mkTopFunBind Generated wrapper_lname [wrapper_match]
-           ; mkPatSynWrapper wrapper_id wrapper_bind }
-    ExplicitBidirectional mg ->
-        do { wrapper_id <- tcLookupPatSynWrapper name
-           ; mkPatSynWrapper wrapper_id $
-               FunBind{ fun_id = L loc (idName wrapper_id)
-                      , fun_infix = False
-                      , fun_matches = mg
-                      , fun_co_fn = idHsWrapper
-                      , bind_fvs = placeHolderNamesTc
-                      , fun_tick = Nothing }}
+           ; mkPatSynWorker lname $ mkMatchGroupName Generated [wrapper_match] }
+    ExplicitBidirectional mg -> mkPatSynWorker lname mg
   where
     args = map unLoc $ case details of
         PrefixPatSyn args -> args
         InfixPatSyn arg1 arg2 -> [arg1, arg2]
 
-    tcLookupPatSynWrapper name
-      = do { patsyn <- tcLookupPatSyn name
-           ; case patSynWrapper patsyn of
-               Nothing -> panic "tcLookupPatSynWrapper"
-               Just wrapper_id -> return wrapper_id }
-
-mkPatSynWrapperId :: Located Name
-                  -> [Var] -> [TyVar] -> [TyVar] -> ThetaType -> Type
-                  -> TcM Id
-mkPatSynWrapperId (L _ name) args univ_tvs ex_tvs theta pat_ty
-  = do { let qtvs = univ_tvs ++ ex_tvs
-       ; (subst, wrapper_tvs) <- tcInstSkolTyVars qtvs
-       ; let wrapper_theta = substTheta subst theta
-             pat_ty' = substTy subst pat_ty
-             args' = map (\arg -> setVarType arg $ substTy subst (varType arg)) args
-             wrapper_tau = mkFunTys (map varType args') pat_ty'
-             wrapper_sigma = mkSigmaTy wrapper_tvs wrapper_theta wrapper_tau
-
-       ; wrapper_name <- newImplicitBinder name mkDataConWrapperOcc
-       ; return $ mkVanillaGlobal wrapper_name wrapper_sigma }
-
-mkPatSynWrapper :: Id
-                -> HsBind Name
+mkPatSynWrapperIds :: Located Name
+                   -> [TyVar] -> ThetaType -> [Type] -> Type
+                   -> TcM (Id, Id)
+mkPatSynWrapperIds lname qtvs theta arg_tys pat_ty
+  = do { worker_id <- mkPatSynWorkerId lname mkDataConWorkerOcc qtvs theta worker_arg_tys pat_ty
+       ; wrapper_id <- mkPatSynWrapperId lname qtvs theta arg_tys pat_ty worker_id
+       ; return (wrapper_id, worker_id) }
+  where
+    worker_arg_tys | need_dummy_arg = [voidPrimTy]
+                   | otherwise = arg_tys
+    need_dummy_arg = null arg_tys && isUnLiftedType pat_ty
+
+mkPatSynWorker :: Located Name
+                -> MatchGroup Name (LHsExpr Name)
                 -> TcM (LHsBinds Id)
-mkPatSynWrapper wrapper_id bind
-  = do { (wrapper_binds, _, _) <- tcPolyCheck NonRecursive (const []) sig (noLoc bind)
-       ; traceTc "tcPatSynDecl wrapper" $ ppr wrapper_binds
-       ; traceTc "tcPatSynDecl wrapper type" $ ppr (varType wrapper_id)
-       ; return wrapper_binds }
+mkPatSynWorker (L loc name) mg
+  = do { patsyn <- tcLookupPatSyn name
+       ; let worker_id = fromMaybe (panic "mkPatSynWrapper") $
+                         patSynWorker patsyn
+             need_dummy_arg = null (patSynArgs patsyn) && isUnLiftedType (patSynType patsyn)
+
+       ; let match_dummy = mkMatch [nlWildPatName] (noLoc $ HsLam mg) emptyLocalBinds
+             mg' | need_dummy_arg = mkMatchGroupName Generated [match_dummy]
+                 | otherwise = mg
+
+       ; let (worker_tvs, worker_theta, worker_tau) = tcSplitSigmaTy (idType worker_id)
+             bind = FunBind { fun_id = L loc (idName worker_id)
+                            , fun_infix = False
+                            , fun_matches = mg'
+                            , fun_co_fn = idHsWrapper
+                            , bind_fvs = placeHolderNamesTc
+                            , fun_tick = Nothing }
+
+             sig = TcSigInfo{ sig_id = worker_id
+                            , sig_tvs = map (\tv -> (Nothing, tv)) worker_tvs
+                            , sig_theta = worker_theta
+                            , sig_tau = worker_tau
+                            , sig_loc = noSrcSpan
+                            }
+
+       ; (worker_binds, _, _) <- tcPolyCheck NonRecursive (const []) sig (noLoc bind)
+       ; traceTc "tcPatSynDecl worker" $ ppr worker_binds
+       ; return worker_binds }
   where
-    sig = TcSigInfo{ sig_id = wrapper_id
-                   , sig_tvs = map (\tv -> (Nothing, tv)) wrapper_tvs
-                   , sig_theta = wrapper_theta
-                   , sig_tau = wrapper_tau
-                   , sig_loc = noSrcSpan
-                   }
-    (wrapper_tvs, wrapper_theta, wrapper_tau) = tcSplitSigmaTy (idType wrapper_id)
 
 \end{code}
 
diff --git a/compiler/typecheck/TcPatSyn.lhs-boot b/compiler/typecheck/TcPatSyn.lhs-boot
index 700137c16c..0e28caa6ca 100644
--- a/compiler/typecheck/TcPatSyn.lhs-boot
+++ b/compiler/typecheck/TcPatSyn.lhs-boot
@@ -10,6 +10,6 @@ import PatSyn    ( PatSyn )
 tcPatSynDecl :: PatSynBind Name Name
              -> TcM (PatSyn, LHsBinds Id)
 
-tcPatSynWrapper :: PatSynBind Name Name
-                -> TcM (LHsBinds Id)
+tcPatSynWorker :: PatSynBind Name Name
+               -> TcM (LHsBinds Id)
 \end{code}
diff --git a/testsuite/.gitignore b/testsuite/.gitignore
index 3a5d81654a..a07a376b26 100644
--- a/testsuite/.gitignore
+++ b/testsuite/.gitignore
@@ -1098,6 +1098,7 @@ mk/ghcconfig*_inplace_bin_ghc-stage2.exe.mk
 /tests/patsyn/should_run/ex-prov-run
 /tests/patsyn/should_run/match
 /tests/patsyn/should_run/match-unboxed
+/tests/patsyn/should_run/unboxed-wrapper
 /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_compile/T9732.hs b/testsuite/tests/patsyn/should_compile/T9732.hs
new file mode 100644
index 0000000000..7fd0515fcf
--- /dev/null
+++ b/testsuite/tests/patsyn/should_compile/T9732.hs
@@ -0,0 +1,4 @@
+{-# LANGUAGE PatternSynonyms, MagicHash #-}
+module ShouldCompile where
+
+pattern P = 0#
diff --git a/testsuite/tests/patsyn/should_compile/all.T b/testsuite/tests/patsyn/should_compile/all.T
index 94950a1e74..55e3b83302 100644
--- a/testsuite/tests/patsyn/should_compile/all.T
+++ b/testsuite/tests/patsyn/should_compile/all.T
@@ -11,3 +11,4 @@ test('export', normal, compile, [''])
 test('T8966', normal, compile, [''])
 test('T9023', normal, compile, [''])
 test('unboxed-bind-bang', normal, compile, [''])
+test('T9732', normal, compile, [''])
diff --git a/testsuite/tests/patsyn/should_fail/all.T b/testsuite/tests/patsyn/should_fail/all.T
index ee5768c95c..b38776e9c3 100644
--- a/testsuite/tests/patsyn/should_fail/all.T
+++ b/testsuite/tests/patsyn/should_fail/all.T
@@ -8,3 +8,4 @@ test('T9161-2', normal, compile_fail, [''])
 test('T9705-1', normal, compile_fail, [''])
 test('T9705-2', normal, compile_fail, [''])
 test('unboxed-bind', normal, compile_fail, [''])
+test('unboxed-wrapper-naked', normal, compile_fail, [''])
diff --git a/testsuite/tests/patsyn/should_fail/unboxed-wrapper-naked.hs b/testsuite/tests/patsyn/should_fail/unboxed-wrapper-naked.hs
new file mode 100644
index 0000000000..6e7cc94391
--- /dev/null
+++ b/testsuite/tests/patsyn/should_fail/unboxed-wrapper-naked.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE PatternSynonyms, MagicHash #-}
+module ShouldFail where
+
+import GHC.Base
+
+pattern P1 = 42#
+
+x = P1
diff --git a/testsuite/tests/patsyn/should_fail/unboxed-wrapper-naked.stderr b/testsuite/tests/patsyn/should_fail/unboxed-wrapper-naked.stderr
new file mode 100644
index 0000000000..e8d89500a8
--- /dev/null
+++ b/testsuite/tests/patsyn/should_fail/unboxed-wrapper-naked.stderr
@@ -0,0 +1,3 @@
+
+unboxed-wrapper-naked.hs:8:1:
+    Top-level bindings for unlifted types aren't allowed: x = P1
diff --git a/testsuite/tests/patsyn/should_run/all.T b/testsuite/tests/patsyn/should_run/all.T
index 9c3f16b0ea..40ec3e3b4e 100644
--- a/testsuite/tests/patsyn/should_run/all.T
+++ b/testsuite/tests/patsyn/should_run/all.T
@@ -4,3 +4,5 @@ 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, [''])
+test('match-unboxed', normal, compile_and_run, [''])
+test('unboxed-wrapper', normal, compile_and_run, [''])
diff --git a/testsuite/tests/patsyn/should_run/match-unboxed.hs b/testsuite/tests/patsyn/should_run/match-unboxed.hs
new file mode 100644
index 0000000000..ec6de0cd70
--- /dev/null
+++ b/testsuite/tests/patsyn/should_run/match-unboxed.hs
@@ -0,0 +1,21 @@
+{-# LANGUAGE PatternSynonyms, MagicHash #-}
+module Main where
+
+import GHC.Base
+
+pattern P1 <- 0#
+pattern P2 <- 1#
+
+f :: Int# -> Int#
+f P1 = 42#
+f P2 = 44#
+
+g :: Int# -> Int
+g P1 = 42
+g P2 = 44
+
+main = do
+    print $ I# (f 0#)
+    print $ I# (f 1#)
+    print $ g 0#
+    print $ g 1#
diff --git a/testsuite/tests/patsyn/should_run/match-unboxed.stdout b/testsuite/tests/patsyn/should_run/match-unboxed.stdout
new file mode 100644
index 0000000000..da4a47e1f3
--- /dev/null
+++ b/testsuite/tests/patsyn/should_run/match-unboxed.stdout
@@ -0,0 +1,4 @@
+42
+44
+42
+44
diff --git a/testsuite/tests/patsyn/should_run/unboxed-wrapper.hs b/testsuite/tests/patsyn/should_run/unboxed-wrapper.hs
new file mode 100644
index 0000000000..367c8ccebd
--- /dev/null
+++ b/testsuite/tests/patsyn/should_run/unboxed-wrapper.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE PatternSynonyms, MagicHash #-}
+module Main where
+
+import GHC.Base
+
+pattern P1 = 42#
+
+main = do
+    print $ I# P1
diff --git a/testsuite/tests/patsyn/should_run/unboxed-wrapper.stdout b/testsuite/tests/patsyn/should_run/unboxed-wrapper.stdout
new file mode 100644
index 0000000000..d81cc0710e
--- /dev/null
+++ b/testsuite/tests/patsyn/should_run/unboxed-wrapper.stdout
@@ -0,0 +1 @@
+42