From 51666a19707f4ca34eec28a14bffbbc7d642e647 Mon Sep 17 00:00:00 2001 From: simonpj Date: Thu, 1 Nov 2001 13:20:06 +0000 Subject: [PATCH] [project @ 2001-11-01 13:20:05 by simonpj] --------------------------------------- Fix a unboxed-binding bug in SpecConstr --------------------------------------- [HEAD only] This fixes a rather obscure bug in the constructor specialiser discovered by Ralf Hinze. It was generating a specialised version of the function with no arguments --- and the function returned an unboxed type. Solution: same as for worker-wrapper; add a dummy argument. Several files are affected because I added CoreUtils.mkPiTypes, as a useful helper function. --- ghc/compiler/basicTypes/MkId.lhs | 12 ++++++- ghc/compiler/coreSyn/CoreUtils.lhs | 21 +++++++----- ghc/compiler/prelude/PrelNames.lhs | 1 + ghc/compiler/simplCore/SetLevels.lhs | 6 ++-- ghc/compiler/simplCore/Simplify.lhs | 6 ++-- ghc/compiler/specialise/SpecConstr.lhs | 22 +++++++++---- ghc/compiler/stranal/WwLib.lhs | 55 ++++++++++++++++++++------------ 7 files changed, 80 insertions(+), 43 deletions(-) diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs index 97adb94..e15b79a 100644 --- a/ghc/compiler/basicTypes/MkId.lhs +++ b/ghc/compiler/basicTypes/MkId.lhs @@ -22,7 +22,7 @@ module MkId ( -- And some particular Ids; see below for why they are wired in wiredInIds, - unsafeCoerceId, realWorldPrimId, nullAddrId, + unsafeCoerceId, realWorldPrimId, voidArgId, nullAddrId, eRROR_ID, eRROR_CSTRING_ID, rEC_SEL_ERROR_ID, pAT_ERROR_ID, rEC_CON_ERROR_ID, rEC_UPD_ERROR_ID, iRREFUT_PAT_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, aBSENT_ERROR_ID, pAR_ERROR_ID @@ -841,6 +841,13 @@ dataToTagId = mkPrimOpId DataToTagOp @realWorld#@ used to be a magic literal, \tr{void#}. If things get nasty as-is, change it back to a literal (@Literal@). +voidArgId is a Local Id used simply as an argument in functions +where we just want an arg to avoid having a thunk of unlifted type. +E.g. + x = \ void :: State# RealWorld -> (# p, q #) + +This comes up in strictness analysis + \begin{code} realWorldPrimId -- :: State# RealWorld = pcMiscPrelId realWorldPrimIdKey pREL_GHC SLIT("realWorld#") @@ -850,6 +857,9 @@ realWorldPrimId -- :: State# RealWorld -- which in turn makes Simplify.interestingArg return True, -- which in turn makes INLINE things applied to realWorld# likely -- to be inlined + +voidArgId -- :: State# RealWorld + = mkSysLocal SLIT("void") voidArgIdKey realWorldStatePrimTy \end{code} diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index 0877888..4e61e83 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -8,7 +8,7 @@ module CoreUtils ( -- Construction mkNote, mkInlineMe, mkSCC, mkCoerce, bindNonRec, needsCaseBinding, - mkIfThenElse, mkAltExpr, mkPiType, + mkIfThenElse, mkAltExpr, mkPiType, mkPiTypes, -- Taking expressions apart findDefault, findAlt, hasDefault, @@ -105,12 +105,18 @@ lbvarinfo field to figure out the right annotation for the arrove in case of a term variable. \begin{code} -mkPiType :: Var -> Type -> Type -- The more polymorphic version doesn't work... -mkPiType v ty | isId v = (case idLBVarInfo v of - LBVarInfo u -> mkUTy u - otherwise -> id) $ - mkFunTy (idType v) ty - | isTyVar v = mkForAllTy v ty +mkPiType :: Var -> Type -> Type -- The more polymorphic version +mkPiTypes :: [Var] -> Type -> Type -- doesn't work... + +mkPiTypes vs ty = foldr mkPiType ty vs + +mkPiType v ty + | isId v = add_usage (mkFunTy (idType v) ty) + | otherwise = mkForAllTy v ty + where + add_usage ty = case idLBVarInfo v of + LBVarInfo u -> mkUTy u ty + otherwise -> ty \end{code} \begin{code} @@ -915,7 +921,6 @@ exprArity e = go e go _ = 0 \end{code} - %************************************************************************ %* * \subsection{Equality} diff --git a/ghc/compiler/prelude/PrelNames.lhs b/ghc/compiler/prelude/PrelNames.lhs index ed4d031..c2da0aa 100644 --- a/ghc/compiler/prelude/PrelNames.lhs +++ b/ghc/compiler/prelude/PrelNames.lhs @@ -847,6 +847,7 @@ printIdKey = mkPreludeMiscIdUnique 43 failIOIdKey = mkPreludeMiscIdUnique 44 unpackCStringListIdKey = mkPreludeMiscIdUnique 45 nullAddrIdKey = mkPreludeMiscIdUnique 46 +voidArgIdKey = mkPreludeMiscIdUnique 47 \end{code} Certain class operations from Prelude classes. They get their own diff --git a/ghc/compiler/simplCore/SetLevels.lhs b/ghc/compiler/simplCore/SetLevels.lhs index ac6f351..6cd9efb 100644 --- a/ghc/compiler/simplCore/SetLevels.lhs +++ b/ghc/compiler/simplCore/SetLevels.lhs @@ -54,7 +54,7 @@ module SetLevels ( import CoreSyn -import CoreUtils ( exprType, exprIsTrivial, exprIsBottom, mkPiType ) +import CoreUtils ( exprType, exprIsTrivial, exprIsBottom, mkPiTypes ) import CoreFVs -- all of it import Subst import Id ( Id, idType, mkSysLocal, isOneShotLambda, zapDemandIdInfo, @@ -727,7 +727,7 @@ newPolyBndrs dest_lvl env abs_vars bndrs mk_poly_bndr bndr uniq = mkSysLocal (_PK_ str) uniq poly_ty where str = "poly_" ++ occNameUserString (getOccName bndr) - poly_ty = foldr mkPiType (idType bndr) abs_vars + poly_ty = mkPiTypes abs_vars (idType bndr) newLvlVar :: String @@ -735,7 +735,7 @@ newLvlVar :: String -> LvlM Id newLvlVar str vars body_ty = getUniqueUs `thenLvl` \ uniq -> - returnUs (mkSysLocal (_PK_ str) uniq (foldr mkPiType body_ty vars)) + returnUs (mkSysLocal (_PK_ str) uniq (mkPiTypes vars body_ty)) -- The deeply tiresome thing is that we have to apply the substitution -- to the rules inside each Id. Grr. But it matters. diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index 0d95dbe..6d49a27 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -37,7 +37,7 @@ import CoreSyn import PprCore ( pprParendExpr, pprCoreExpr ) import CoreUnfold ( mkOtherCon, mkUnfolding, otherCons, callSiteInline ) import CoreUtils ( exprIsDupable, exprIsTrivial, needsCaseBinding, - exprIsConApp_maybe, mkPiType, findAlt, + exprIsConApp_maybe, mkPiTypes, findAlt, exprType, coreAltsType, exprIsValue, exprOkForSpeculation, exprArity, findDefault, mkCoerce, mkSCC, mkInlineMe, mkAltExpr, applyTypeToArg @@ -1686,8 +1686,8 @@ mkDupableAlt env case_bndr' cont alt@(con, bndrs, rhs) ) `thenSmpl` \ (final_bndrs', final_args) -> -- See comment about "$j" name above - newId SLIT("$j") (foldr mkPiType rhs_ty' final_bndrs') `thenSmpl` \ join_bndr -> - -- Notice the funky mkPiType. If the contructor has existentials + newId SLIT("$j") (mkPiTypes final_bndrs' rhs_ty') `thenSmpl` \ join_bndr -> + -- Notice the funky mkPiTypes. If the contructor has existentials -- it's possible that the join point will be abstracted over -- type varaibles as well as term variables. -- Example: Suppose we have diff --git a/ghc/compiler/specialise/SpecConstr.lhs b/ghc/compiler/specialise/SpecConstr.lhs index 574e039..b5dde8d 100644 --- a/ghc/compiler/specialise/SpecConstr.lhs +++ b/ghc/compiler/specialise/SpecConstr.lhs @@ -12,8 +12,9 @@ module SpecConstr( import CoreSyn import CoreLint ( showPass, endPass ) -import CoreUtils ( exprType, eqExpr ) +import CoreUtils ( exprType, eqExpr, mkPiTypes ) import CoreFVs ( exprsFreeVars ) +import WwLib ( mkWorkerArgs ) import DataCon ( dataConRepArity ) import Type ( tyConAppArgs ) import PprCore ( pprCoreRules ) @@ -489,8 +490,9 @@ spec_one :: ScEnv f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw -} -spec_one env fn rhs (pats, n) - = getUniqueUs `thenUs` \ spec_uniq -> +spec_one env fn rhs (pats, rule_number) + = getUniqueUs `thenUs` \ spec_uniq -> + getUniqueUs `thenUs` \ hack_uniq -> let fn_name = idName fn fn_loc = nameSrcLoc fn_name @@ -502,12 +504,18 @@ spec_one env fn rhs (pats, n) -- variable may mention a type variable (tvs, ids) = partition isTyVar vars_to_bind bndrs = tvs ++ ids + spec_body = mkApps rhs pats + body_ty = exprType spec_body - rule_name = _PK_ ("SC:" ++ showSDoc (ppr fn <> int n)) - spec_rhs = mkLams bndrs (mkApps rhs pats) - spec_id = mkUserLocal spec_occ spec_uniq (exprType spec_rhs) fn_loc + (spec_lam_args, spec_call_args) = mkWorkerArgs bndrs body_ty + -- Usual w/w hack to avoid generating + -- a spec_rhs of unlifted type and no args + + rule_name = _PK_ ("SC:" ++ showSDoc (ppr fn <> int rule_number)) + spec_rhs = mkLams spec_lam_args spec_body + spec_id = mkUserLocal spec_occ spec_uniq (mkPiTypes spec_lam_args body_ty) fn_loc rule = Rule rule_name specConstrActivation - bndrs pats (mkVarApps (Var spec_id) bndrs) + bndrs pats (mkVarApps (Var spec_id) spec_call_args) in returnUs (rule, (spec_id, spec_rhs)) diff --git a/ghc/compiler/stranal/WwLib.lhs b/ghc/compiler/stranal/WwLib.lhs index 4d053ea..e74de63 100644 --- a/ghc/compiler/stranal/WwLib.lhs +++ b/ghc/compiler/stranal/WwLib.lhs @@ -4,7 +4,7 @@ \section[WwLib]{A library for the ``worker/wrapper'' back-end to the strictness analyser} \begin{code} -module WwLib ( mkWwBodies, mkWWstr ) where +module WwLib ( mkWwBodies, mkWWstr, mkWorkerArgs ) where #include "HsVersions.h" @@ -18,7 +18,7 @@ import IdInfo ( vanillaIdInfo ) import DataCon ( splitProductType_maybe, splitProductType ) import NewDemand ( Demand(..), Keepity(..), DmdResult(..) ) import DmdAnal ( both ) -import PrelInfo ( realWorldPrimId, eRROR_CSTRING_ID ) +import MkId ( realWorldPrimId, voidArgId, eRROR_CSTRING_ID ) import TysPrim ( realWorldStatePrimTy ) import TysWiredIn ( tupleCon ) import Type ( Type, isUnLiftedType, mkFunTys, @@ -125,8 +125,9 @@ mkWwBodies fun_ty demands res_info one_shots = mkWWargs fun_ty demands one_shots' `thenUs` \ (wrap_args, wrap_fn_args, work_fn_args, res_ty) -> mkWWcpr res_ty res_info `thenUs` \ (wrap_fn_cpr, work_fn_cpr, cpr_res_ty) -> mkWWstr wrap_args `thenUs` \ (work_args, wrap_fn_str, work_fn_str) -> - hackWorkArgs work_args cpr_res_ty `thenUs` \ (work_lam_args, work_call_args) -> - + let + (work_lam_args, work_call_args) = mkWorkerArgs work_args cpr_res_ty + in returnUs ([idNewDemandInfo v | v <- work_args, isId v], Note InlineMe . wrap_fn_args . wrap_fn_cpr . wrap_fn_str . applyToVars work_call_args . Var, mkLams work_lam_args . work_fn_str . work_fn_cpr . work_fn_args) @@ -139,24 +140,36 @@ mkWwBodies fun_ty demands res_info one_shots -- fw from being inlined into f's RHS where one_shots' = one_shots ++ repeat False +\end{code} - -- Horrid special case. If the worker would have no arguments, and the - -- function returns a primitive type value, that would make the worker into - -- an unboxed value. We box it by passing a dummy void argument, thus: - -- - -- f = /\abc. \xyz. fw abc void - -- fw = /\abc. \v. body - -- - -- We use the state-token type which generates no code -hackWorkArgs work_args res_ty - | any isId work_args || not (isUnLiftedType res_ty) - = returnUs (work_args, work_args) - | otherwise - = getUniqueUs `thenUs` \ void_arg_uniq -> - let - void_arg = mk_ww_local void_arg_uniq realWorldStatePrimTy - in - returnUs (work_args ++ [void_arg], work_args ++ [realWorldPrimId]) + +%************************************************************************ +%* * +\subsection{Making wrapper args} +%* * +%************************************************************************ + +During worker-wrapper stuff we may end up with an unlifted thing +which we want to let-bind without losing laziness. So we +add a void argument. E.g. + + f = /\a -> \x y z -> E::Int# -- E does not mentione x,y,z +==> + fw = /\ a -> \void -> E + f = /\ a -> \x y z -> fw realworld + +We use the state-token type which generates no code. + +\begin{code} +mkWorkerArgs :: [Var] + -> Type -- Type of body + -> ([Var], -- Lambda bound args + [Var]) -- Args at call site +mkWorkerArgs args res_ty + | any isId args || not (isUnLiftedType res_ty) + = (args, args) + | otherwise + = (args ++ [voidArgId], args ++ [realWorldPrimId]) \end{code} -- 1.7.10.4