[Git][ghc/ghc][wip/with2-primop] 2 commits: Beta reduce state token

[Ben Gamari]

Ben Gamari pushed to branch wip/with2-primop at Glasgow Haskell Compiler / GHC


Commits:
a9333176 by Ben Gamari at 2020-04-17T18:19:39+00:00
Beta reduce state token

- - - - -
0040f7cc by Ben Gamari at 2020-04-17T20:16:37+00:00
Fix warnings

- - - - -


2 changed files:

- compiler/GHC/Core/Op/Simplify.hs
- compiler/GHC/CoreToStg/Prep.hs


Changes:

=====================================
compiler/GHC/Core/Op/Simplify.hs
=====================================
@@ -51,7 +51,6 @@ import GHC.Core.FVs     ( mkRuleInfo )
 import GHC.Core.Rules   ( lookupRule, getRules )
 import GHC.Types.Basic  ( TopLevelFlag(..), isNotTopLevel, isTopLevel,
                           RecFlag(..), Arity )
-import GHC.Types.Unique ( hasKey )
 import PrelNames        ( keepAliveIdKey )
 import MonadUtils       ( mapAccumLM, liftIO )
 import GHC.Types.Var    ( isTyCoVar )
@@ -1906,14 +1905,11 @@ rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args }) cont
     , TyArg {as_arg_ty=arg_ty}
     , TyArg {as_arg_ty=arg_rep}
     ] <- rev_args
+    -- Extract type of second component of (# State# RealWorld, a #)
+  , Just (_, [_, _, _, ty']) <- splitTyConApp_maybe (contResultType cont)
   = do { (env', f_arg) <- simplLamBndr (zapSubstEnv env) f_arg
        ; f_body' <- simplExprC env' f_body cont
        ; let f' = Lam f_arg f_body'
-             -- Extract type of second component of (# State# RealWorld, a #)
-             ty' = case splitTyConApp_maybe (contResultType cont) of
-                     Just (tc, [_, _, _, ty]) -> ty
-                     Nothing -> panic "rebuildCall: Malformed (#,#) type"
-
        ; let call' = mkApps (Var fun)
                [ mkTyArg arg_rep, mkTyArg arg_ty
                , mkTyArg (getRuntimeRep ty'), mkTyArg ty'


=====================================
compiler/GHC/CoreToStg/Prep.hs
=====================================
@@ -869,6 +869,10 @@ cpeApp top_env expr
              ; y <- newVar result_ty
              ; s1 <- newVar realWorldStatePrimTy
              ; s2 <- newVar realWorldStatePrimTy
+               -- Beta reduce
+             ; (floats0, k') <- case k of
+                       Lam s body -> cpe_app (extendCorePrepEnvExpr env s s0) body [] 0
+                       _          -> cpe_app env k [CpeApp s0] 1
              ; let touchId = mkPrimOpId TouchOp
 
                    -- @stateResultAlt s y expr@ is a case alternative of the form,
@@ -877,12 +881,13 @@ cpeApp top_env expr
                    stateResultAlt stateVar resultVar rhs =
                      (DataAlt (tupleDataCon Unboxed 2), [stateVar, resultVar], rhs)
 
-                   expr = Case (App k s0) b0 out_ty [stateResultAlt s1 y rhs1]
+                   expr = Case k' b0 out_ty [stateResultAlt s1 y rhs1]
                    rhs1 = let scrut = mkApps (Var touchId) [Type arg_rep, Type arg_ty, x, Var s1]
                           in Case scrut s2 out_ty [(DEFAULT, [], rhs2)]
                    rhs2 = mkApps (Var $ dataConWrapId $ tupleDataCon Unboxed 2)
                             [mkTyArg voidRepTy, mkTyArg result_rep, mkTyArg realWorldStatePrimTy, mkTyArg result_ty, Var s2, Var y]
-             ; cpeBody env expr
+             ; (floats1, body) <- pprTrace "cpe_app" (ppr expr) $ cpeBody env expr
+             ; return (floats0 `appendFloats` floats1, body)
              }
     cpe_app _env (Var f) args _
         | f `hasKey` keepAliveIdKey



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/75093e219f059a57ee4358eb3e787ff87d7fec13...0040f7ccaeb8a0f6945662c805eaa6c4bcc2023c

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/75093e219f059a57ee4358eb3e787ff87d7fec13...0040f7ccaeb8a0f6945662c805eaa6c4bcc2023c
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200417/a5adffc2/attachment-0001.html>