[Git][ghc/ghc][wip/with2-primop] 2 commits: Fix it

[Ben Gamari]

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


Commits:
fd23f36f by Ben Gamari at 2020-04-15T21:15:07-04:00
Fix it

- - - - -
b4cb0d76 by Ben Gamari at 2020-04-15T21:15:10-04:00
Add debug output to getCallMethod

- - - - -


3 changed files:

- compiler/GHC/CoreToStg/Prep.hs
- compiler/GHC/Stg/Lint.hs
- compiler/GHC/StgToCmm/Closure.hs


Changes:

=====================================
compiler/GHC/CoreToStg/Prep.hs
=====================================
@@ -857,13 +857,15 @@ cpeApp top_env expr
             _          -> cpe_app env arg [CpeApp (Var realWorldPrimId)] 1
 
     -- See Note [CorePrep handling of keepAlive#]
-    cpe_app env (Var f) [CpeApp (Type _arg_rep), CpeApp (Type arg_ty),
+    cpe_app env (Var f) [CpeApp (Type arg_rep), CpeApp (Type arg_ty),
                          CpeApp (Type result_rep), CpeApp (Type result_ty),
                          CpeApp x, CpeApp k, CpeApp s0] 3
         | f `hasKey` keepAliveIdKey
         = do { let voidRepTy = primRepToRuntimeRep VoidRep
-             ; b0 <- newVar $ mkTyConApp (tupleTyCon Unboxed 2)
-                                         [voidRepTy, result_rep, realWorldStatePrimTy, result_ty]
+                   -- out_ty ~ (# State# RealWorld, a #)
+                   out_ty = mkTyConApp (tupleTyCon Unboxed 2)
+                                       [voidRepTy, result_rep, realWorldStatePrimTy, result_ty]
+             ; b0 <- newVar out_ty
              ; y <- newVar result_ty
              ; s1 <- newVar realWorldStatePrimTy
              ; s2 <- newVar realWorldStatePrimTy
@@ -875,9 +877,11 @@ cpeApp top_env expr
                    stateResultAlt stateVar resultVar rhs =
                      (DataAlt (tupleDataCon Unboxed 2), [stateVar, resultVar], rhs)
 
-                   expr = Case (App k s0) b0 (varType b0) [stateResultAlt s1 y rhs1]
-                   rhs1 = Case (mkApps (Var touchId) [Type arg_ty, x, Var s1]) s1 (varType s1) [(DEFAULT, [], rhs2)]
-                   rhs2 = mkApps (Var $ dataConWrapId $ tupleDataCon Unboxed 2) [Var s2, Var y]
+                   expr = Case (App k s0) 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
              }
     cpe_app _env (Var f) args _


=====================================
compiler/GHC/Stg/Lint.hs
=====================================
@@ -104,7 +104,9 @@ lintStgArg (StgLitArg _) = return ()
 lintStgArg (StgVarArg v) = lintStgVar v
 
 lintStgVar :: Id -> LintM ()
-lintStgVar id = checkInScope id
+lintStgVar id
+  | id `hasKey` keepAliveIdKey = addErrL (text "keepAlive# not permitted in STG")
+  | otherwise = checkInScope id
 
 lintStgBinds
     :: (OutputablePass a, BinderP a ~ Id)


=====================================
compiler/GHC/StgToCmm/Closure.hs
=====================================
@@ -539,7 +539,7 @@ data CallMethod
 
 getCallMethod :: DynFlags
               -> Name           -- Function being applied
-              -> Id             -- Function Id used to chech if it can refer to
+              -> Id             -- Function Id used to check if it can refer to
                                 -- CAF's and whether the function is tail-calling
                                 -- itself
               -> LambdaFormInfo -- Its info
@@ -626,7 +626,7 @@ getCallMethod _ _name _ LFLetNoEscape _n_args _v_args (LneLoc blk_id lne_regs)
               _self_loop_info
   = JumpToIt blk_id lne_regs
 
-getCallMethod _ _ _ _ _ _ _ _ = panic "Unknown call method"
+getCallMethod _ name _ lf_info _ _ _ _ = pprPanic "Unknown call method" (ppr name $$ ppr lf_info)
 
 -----------------------------------------------------------------------------
 --              Data types for closure information



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7b01122e0159f2abeccef0376745e46355501555...b4cb0d769661ea02daca624af15db0bee01d9930

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7b01122e0159f2abeccef0376745e46355501555...b4cb0d769661ea02daca624af15db0bee01d9930
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/20200415/8932cb44/attachment-0001.html>