Commit 51666a19 authored by simonpj's avatar simonpj
Browse files

[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.
parent 375b5a8a
......@@ -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}
......
......@@ -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}
......
......@@ -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
......
......@@ -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.
......
......@@ -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
......
......@@ -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))
......
......@@ -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}
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment