[commit: ghc] wip/T12618: Create a simple wrapper for built-in types as well (395db23)

[git at git.haskell.org]

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

On branch  : wip/T12618
Link       : http://ghc.haskell.org/trac/ghc/changeset/395db23544dbde568bfaf71966123b7b8388e971/ghc

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

commit 395db23544dbde568bfaf71966123b7b8388e971
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Wed Oct 5 17:16:59 2016 -0400

    Create a simple wrapper for built-in types as well
    
    (The module structure might need some refactoring here.)


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

395db23544dbde568bfaf71966123b7b8388e971
 compiler/basicTypes/MkId.hs      | 41 +++++++++++++++++++++++++++++++++++++++-
 compiler/basicTypes/MkId.hs-boot |  4 +++-
 compiler/prelude/TysWiredIn.hs   | 13 ++++++++-----
 3 files changed, 51 insertions(+), 7 deletions(-)

diff --git a/compiler/basicTypes/MkId.hs b/compiler/basicTypes/MkId.hs
index 8f61d96..0601ba4 100644
--- a/compiler/basicTypes/MkId.hs
+++ b/compiler/basicTypes/MkId.hs
@@ -23,7 +23,8 @@ module MkId (
         wrapFamInstBody, unwrapFamInstScrut,
         wrapTypeUnbranchedFamInstBody, unwrapTypeUnbranchedFamInstScrut,
 
-        DataConBoxer(..), mkDataConRep, mkDataConWorkId, dataConWorkStrictSig,
+        DataConBoxer(..), mkDataConRep, mkSimpleDataConRep,
+        mkDataConWorkId, dataConWorkStrictSig,
 
         -- And some particular Ids; see below for why they are wired in
         wiredInIds, ghcPrimIds,
@@ -467,6 +468,44 @@ newtype DataConBoxer = DCB ([Type] -> [Var] -> UniqSM ([Var], [CoreBind]))
                        -- Bind these src-level vars, returning the
                        -- rep-level vars to bind in the pattern
 
+unitDataConBoxer :: DataConBoxer
+unitDataConBoxer = DCB (\_ vs -> return (vs, []))
+
+mkSimpleDataConRep :: Name -> DataCon -> DataConRep
+mkSimpleDataConRep wrap_name dc = DCR { dcr_wrap_id = wrap_id
+                                      , dcr_boxer   = unitDataConBoxer
+                                      , dcr_arg_tys = arg_tys
+                                      , dcr_stricts = rep_strs
+                                      , dcr_bangs   = arg_ibangs }
+  where
+    wrap_ty = dataConRepType dc
+    wrap_id = mkGlobalId (DataConWrapId dc) wrap_name wrap_ty wrap_info
+    (ty_vars, theta , orig_arg_tys, _) = dataConSig dc
+    arg_tys = theta ++ orig_arg_tys
+    wrap_args = [ mkSysLocalOrCoVar (fsLit "wa") (mkCoreConAppUnique i) ty
+           | (i,ty) <- zip [0..] arg_tys ]
+
+    wrap_info = noCafIdInfo
+                `setArityInfo`         wrap_arity
+                    -- It's important to specify the arity, so that partial
+                    -- applications are treated as values
+                `setInlinePragInfo`    alwaysInlinePragma
+                `setUnfoldingInfo`     wrap_unf
+                `setStrictnessInfo`    wrap_sig
+    wrap_arity = dataConRepArity dc
+    wrap_unf = mkInlineUnfolding (Just wrap_arity) wrap_rhs
+    wrap_sig = mkClosedStrictSig wrap_arg_dmds (dataConCPR dc)
+    wrap_arg_dmds = replicate wrap_arity topDmd
+    rep_strs = [ NotMarkedStrict | _ <- arg_tys ]
+    arg_ibangs = [ HsLazy | _ <- arg_tys ]
+
+    wrap_rhs = mkLams ty_vars $
+               mkLams wrap_args $
+               mkConApp dc $ concat
+                [ map (Type . mkTyVarTy) ty_vars
+                , map varToCoreExpr wrap_args
+                ]
+
 mkDataConRep :: DynFlags
              -> FamInstEnvs
              -> Name
diff --git a/compiler/basicTypes/MkId.hs-boot b/compiler/basicTypes/MkId.hs-boot
index 0a9ac2c..238954f 100644
--- a/compiler/basicTypes/MkId.hs-boot
+++ b/compiler/basicTypes/MkId.hs-boot
@@ -2,11 +2,13 @@ module MkId where
 import Name( Name )
 import Var( Id )
 import Class( Class )
-import {-# SOURCE #-} DataCon( DataCon )
+import {-# SOURCE #-} DataCon( DataCon, DataConRep )
 import {-# SOURCE #-} PrimOp( PrimOp )
 
 data DataConBoxer
 
+mkSimpleDataConRep :: Name -> DataCon -> DataConRep
+
 mkDataConWorkId :: Name -> DataCon -> Id
 mkDictSelId     :: Name -> Class   -> Id
 
diff --git a/compiler/prelude/TysWiredIn.hs b/compiler/prelude/TysWiredIn.hs
index b1d0f52..25dd64d 100644
--- a/compiler/prelude/TysWiredIn.hs
+++ b/compiler/prelude/TysWiredIn.hs
@@ -122,7 +122,7 @@ module TysWiredIn (
 #include "HsVersions.h"
 #include "MachDeps.h"
 
-import {-# SOURCE #-} MkId( mkDataConWorkId, mkDictSelId )
+import {-# SOURCE #-} MkId( mkDataConWorkId, mkSimpleDataConRep, mkDictSelId )
 
 -- friends:
 import PrelNames
@@ -505,7 +505,7 @@ pcDataConWithFixity' :: Bool -> Name -> Unique -> Unique -> RuntimeRepInfo
 -- The Name should be in the DataName name space; it's the name
 -- of the DataCon itself.
 
-pcDataConWithFixity' declared_infix dc_name wrk_key _wrp_key rri tyvars ex_tyvars arg_tys tycon
+pcDataConWithFixity' declared_infix dc_name wrk_key wrp_key rri tyvars ex_tyvars arg_tys tycon
   = data_con
   where
     data_con = mkDataCon dc_name declared_infix prom_info
@@ -520,9 +520,7 @@ pcDataConWithFixity' declared_infix dc_name wrk_key _wrp_key rri tyvars ex_tyvar
                 tycon
                 []      -- No stupid theta
                 (mkDataConWorkId wrk_name data_con)
-                NoDataConRep    -- Wired-in types are too simple to need wrappers
-                                -- TODO #12618 should be generating a wrapper
-                                -- here, but we cannot use Core here!
+                (mkSimpleDataConRep wrp_name data_con)
 
     no_bang = HsSrcBang Nothing NoSrcUnpack NoSrcStrict
 
@@ -533,8 +531,13 @@ pcDataConWithFixity' declared_infix dc_name wrk_key _wrp_key rri tyvars ex_tyvar
     wrk_name = mkWiredInName modu wrk_occ wrk_key
                              (AnId (dataConWorkId data_con)) UserSyntax
 
+    wrp_occ  = mkDataConWrapperOcc dc_occ
+    wrp_name = mkWiredInName modu wrp_occ wrp_key
+                             (AnId (dataConWrapId data_con)) UserSyntax
+
     prom_info = mkPrelTyConRepName dc_name
 
+
 -- used for RuntimeRep and friends
 pcSpecialDataCon :: Name -> [Type] -> TyCon -> RuntimeRepInfo -> DataCon
 pcSpecialDataCon dc_name arg_tys tycon rri