DsBinds.lhs 15.2 KB
Newer Older
1
%
2
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3
%
4
\section[DsBinds]{Pattern-matching bindings (HsBinds and MonoBinds)}
5

6 7 8
Handles @HsBinds@; those at the top level require different handling,
in that the @Rec@/@NonRec@/etc structure is thrown away (whereas at
lower levels it is preserved with @let@/@letrec@s).
9 10

\begin{code}
11 12 13 14
module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, 
		 dsCoercion,
		 AutoScc(..)
  ) where
15

16 17
#include "HsVersions.h"

18

19
import {-# SOURCE #-}	DsExpr( dsLExpr, dsExpr )
20 21
import {-# SOURCE #-}	Match( matchWrapper )

22 23 24
import DsMonad
import DsGRHSs		( dsGuarded )
import DsUtils
25

26 27
import HsSyn		-- lots of things
import CoreSyn		-- lots of things
28
import CoreUtils	( exprType, mkInlineMe, mkSCC )
29

30
import OccurAnal	( occurAnalyseExpr )
31
import CostCentre	( mkAutoCC, IsCafCC(..) )
32
import Id		( Id, DictId, idType, idName, mkLocalId, setInlinePragma )
33
import Rules		( addIdSpecialisations, mkLocalRule )
34
import Var		( TyVar, Var, isGlobalId, setIdNotExported )
35
import VarEnv
36
import Type		( mkTyVarTy, substTyWith )
37
import TysWiredIn	( voidTy )
38
import Module		( Module )
39
import Outputable
40
import SrcLoc		( Located(..) )
41
import Maybes		( catMaybes, orElse )
42
import Bag		( bagToList )
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
43
import BasicTypes	( Activation(..), InlineSpec(..), isAlwaysActive )
44
import Monad		( foldM )
45 46 47
import FastString	( mkFastString )
import List		( (\\) )
import Util		( mapSnd )
48 49 50 51 52 53 54 55 56
\end{code}

%************************************************************************
%*									*
\subsection[dsMonoBinds]{Desugaring a @MonoBinds@}
%*									*
%************************************************************************

\begin{code}
57 58
dsTopLHsBinds :: AutoScc -> LHsBinds Id -> DsM [(Id,CoreExpr)]
dsTopLHsBinds auto_scc binds = ds_lhs_binds auto_scc binds
59

60 61
dsLHsBinds :: LHsBinds Id -> DsM [(Id,CoreExpr)]
dsLHsBinds binds = ds_lhs_binds NoSccs binds
62

63 64 65 66 67

------------------------
ds_lhs_binds :: AutoScc -> LHsBinds Id -> DsM [(Id,CoreExpr)]
	 -- scc annotation policy (see below)
ds_lhs_binds auto_scc binds =  foldM (dsLHsBind auto_scc) [] (bagToList binds)
68

69 70 71 72 73 74
dsLHsBind :: AutoScc
	 -> [(Id,CoreExpr)]	-- Put this on the end (avoid quadratic append)
	 -> LHsBind Id
	 -> DsM [(Id,CoreExpr)] -- Result
dsLHsBind auto_scc rest (L loc bind)
  = putSrcSpanDs loc $ dsHsBind auto_scc rest bind
75

76 77 78 79
dsHsBind :: AutoScc
	 -> [(Id,CoreExpr)]	-- Put this on the end (avoid quadratic append)
	 -> HsBind Id
	 -> DsM [(Id,CoreExpr)] -- Result
80

81 82
dsHsBind auto_scc rest (VarBind var expr)
  = dsLExpr expr		`thenDs` \ core_expr ->
83

sof's avatar
sof committed
84 85 86
	-- Dictionary bindings are always VarMonoBinds, so
	-- we only need do this here
    addDictScc var core_expr	`thenDs` \ core_expr' ->
87
    returnDs ((var, core_expr') : rest)
88

89
dsHsBind auto_scc rest (FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn })
90
  = matchWrapper (FunRhs (idName fun)) matches		`thenDs` \ (args, body) ->
91
    dsCoercion co_fn (return (mkLams args body))	`thenDs` \ rhs ->
92
    returnDs ((fun,rhs) : rest)
93

94
dsHsBind auto_scc rest (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty })
95
  = dsGuarded grhss ty				`thenDs` \ body_expr ->
96
    mkSelectorBinds pat body_expr		`thenDs` \ sel_binds ->
sof's avatar
sof committed
97
    returnDs (sel_binds ++ rest)
sof's avatar
sof committed
98

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
99 100 101 102 103 104 105 106
-- Note [Rules and inlining]
-- Common special case: no type or dictionary abstraction
-- This is a bit less trivial than you might suppose
-- The naive way woudl be to desguar to something like
--	f_lcl = ...f_lcl...	-- The "binds" from AbsBinds
--	M.f = f_lcl		-- Generated from "exports"
-- But we don't want that, because if M.f isn't exported,
-- it'll be inlined unconditionally at every call site (its rhs is 
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
107
-- trivial).  That would be ok unless it has RULES, which would 
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
108 109 110 111 112 113 114 115 116 117 118 119 120 121
-- thereby be completely lost.  Bad, bad, bad.
--
-- Instead we want to generate
--	M.f = ...f_lcl...
--	f_lcl = M.f
-- Now all is cool. The RULES are attached to M.f (by SimplCore), 
-- and f_lcl is rapidly inlined away.
--
-- This does not happen in the same way to polymorphic binds,
-- because they desugar to
--	M.f = /\a. let f_lcl = ...f_lcl... in f_lcl
-- Although I'm a bit worried about whether full laziness might
-- float the f_lcl binding out and then inline M.f at its call site

122
dsHsBind auto_scc rest (AbsBinds [] [] exports binds)
123 124
  = do	{ core_prs <- ds_lhs_binds NoSccs binds
	; let env = mkABEnv exports
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
125
	      do_one (lcl_id, rhs) | Just (gbl_id, prags) <- lookupVarEnv env lcl_id
126 127
				   = addInlinePrags prags gbl_id $
				     addAutoScc auto_scc gbl_id rhs
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
128 129 130 131 132
				   | otherwise = (lcl_id, rhs)
	      locals'  = [(lcl_id, Var gbl_id) | (_, gbl_id, lcl_id, _) <- exports]
	; return (map do_one core_prs ++ locals' ++ rest) }
		-- No Rec needed here (contrast the other AbsBinds cases)
		-- because we can rely on the enclosing dsBind to wrap in Rec
133 134 135

	-- Another common case: one exported variable
	-- Non-recursive bindings come through this way
136
dsHsBind auto_scc rest
137
     (AbsBinds all_tyvars dicts exports@[(tyvars, global, local, prags)] binds)
sof's avatar
sof committed
138
  = ASSERT( all (`elem` tyvars) all_tyvars )
139
    ds_lhs_binds NoSccs binds 	`thenDs` \ core_prs ->
sof's avatar
sof committed
140
    let 
141 142
	-- Always treat the binds as recursive, because the typechecker
	-- makes rather mixed-up dictionary bindings
143
	core_bind = Rec core_prs
sof's avatar
sof committed
144
    in
145 146 147 148 149 150
    mappM (dsSpec all_tyvars dicts tyvars global local core_bind) 
	  prags				`thenDs` \ mb_specs ->
    let
	(spec_binds, rules) = unzip (catMaybes mb_specs)
	global' = addIdSpecialisations global rules
	rhs'    = mkLams tyvars $ mkLams dicts $ Let core_bind (Var local)
151
	bind    = addInlinePrags prags global' $ addAutoScc auto_scc global' rhs'
152
    in
153
    returnDs (bind  : spec_binds ++ rest)
sof's avatar
sof committed
154

155
dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds)
156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206
  = do	{ core_prs <- ds_lhs_binds NoSccs binds
	; let env = mkABEnv exports
	      do_one (lcl_id,rhs) | Just (gbl_id, prags) <- lookupVarEnv env lcl_id
			          = addInlinePrags prags lcl_id $
				    addAutoScc auto_scc gbl_id rhs
				  | otherwise = (lcl_id,rhs)
	       
		-- Rec because of mixed-up dictionary bindings
	      core_bind = Rec (map do_one core_prs)

	      tup_expr      = mkTupleExpr locals
	      tup_ty	    = exprType tup_expr
	      poly_tup_expr = mkLams all_tyvars $ mkLams dicts $
	 	     	      Let core_bind tup_expr
	      locals        = [local | (_, _, local, _) <- exports]
	      local_tys     = map idType locals

	; poly_tup_id <- newSysLocalDs (exprType poly_tup_expr)

	; let dict_args = map Var dicts

	      mk_bind ((tyvars, global, local, prags), n)	-- locals !! n == local
	        = 	-- Need to make fresh locals to bind in the selector, because
		      	-- some of the tyvars will be bound to voidTy
		  do { locals' <- newSysLocalsDs (map substitute local_tys)
		     ; tup_id  <- newSysLocalDs  (substitute tup_ty)
		     ; mb_specs <- mapM (dsSpec all_tyvars dicts tyvars global local core_bind) 
				      	 prags
		     ; let (spec_binds, rules) = unzip (catMaybes mb_specs)
			   global' = addIdSpecialisations global rules
	                   rhs = mkLams tyvars $ mkLams dicts $
	      	     		 mkTupleSelector locals' (locals' !! n) tup_id $
			         mkApps (mkTyApps (Var poly_tup_id) ty_args) dict_args
		     ; returnDs ((global', rhs) : spec_binds) }
	        where
	          mk_ty_arg all_tyvar | all_tyvar `elem` tyvars = mkTyVarTy all_tyvar
	      			      | otherwise		= voidTy
	          ty_args    = map mk_ty_arg all_tyvars
	          substitute = substTyWith all_tyvars ty_args

	; export_binds_s <- mappM mk_bind (exports `zip` [0..])
	     -- don't scc (auto-)annotate the tuple itself.

	; returnDs ((poly_tup_id, poly_tup_expr) : 
		    (concat export_binds_s ++ rest)) }

mkABEnv :: [([TyVar], Id, Id, [Prag])] -> VarEnv (Id, [Prag])
-- Takes the exports of a AbsBinds, and returns a mapping
--	lcl_id -> (gbl_id, prags)
mkABEnv exports = mkVarEnv [ (lcl_id, (gbl_id, prags)) 
			   | (_, gbl_id, lcl_id, prags) <- exports]
207 208


209 210 211 212 213 214
dsSpec :: [TyVar] -> [DictId] -> [TyVar]
       -> Id -> Id		-- Global, local
       -> CoreBind -> Prag
       -> DsM (Maybe ((Id,CoreExpr), 	-- Binding for specialised Id
		      CoreRule))	-- Rule for the Global Id

215 216
-- Example:
--	f :: (Eq a, Ix b) => a -> b -> b
217
--	{-# SPECIALISE f :: Ix b => Int -> b -> b #-}
218 219 220 221 222 223 224 225 226 227
--
--	AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds
-- 
-- 	SpecPrag (/\b.\(d:Ix b). f Int b dInt d) 
--		 (forall b. Ix b => Int -> b -> b)
--
-- Rule: 	forall b,(d:Ix b). f Int b dInt d = f_spec b d
--
-- Spec bind:	f_spec = Let f = /\ab \(d1:Eq a)(d2:Ix b). let binds in f_mono 
--			 /\b.\(d:Ix b). in f Int b dInt d
228 229
--		The idea is that f occurs just once, so it'll be 
--		inlined and specialised
230 231 232 233 234

dsSpec all_tvs dicts tvs poly_id mono_id mono_bind (InlinePrag {})
  = return Nothing

dsSpec all_tvs dicts tvs poly_id mono_id mono_bind
235
       (SpecPrag spec_expr spec_ty const_dicts inl)
236
  = do	{ let poly_name = idName poly_id
237
	; spec_name <- newLocalName poly_name
238 239 240 241 242
	; ds_spec_expr  <- dsExpr spec_expr
	; let (bndrs, body) = collectBinders ds_spec_expr
	      mb_lhs  	    = decomposeRuleLhs (bndrs ++ const_dicts) body

	; case mb_lhs of
243
	    Nothing -> do { warnDs msg; return Nothing }
244

245
	    Just (bndrs', var, args) -> return (Just (addInlineInfo inl spec_id spec_rhs, rule))
246
		where
247 248 249
		  local_poly  = setIdNotExported poly_id
			-- Very important to make the 'f' non-exported,
			-- else it won't be inlined!
250
		  spec_id     = mkLocalId spec_name spec_ty
251
		  spec_rhs    = Let (NonRec local_poly poly_f_body) ds_spec_expr
252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275
		  poly_f_body = mkLams (tvs ++ dicts) $
			   	fix_up (Let mono_bind (Var mono_id))

			-- Quantify over constant dicts on the LHS, since
			-- their value depends only on their type
			-- The ones we are interested in may even be imported
			-- e.g. GHC.Base.dEqInt

		  rule =  mkLocalRule (mkFastString ("SPEC " ++ showSDoc (ppr poly_name)))
				AlwaysActive poly_name
			        bndrs'	-- Includes constant dicts
				args
				(mkVarApps (Var spec_id) bndrs)
	}
  where
	-- Bind to voidTy any of all_ptvs that aren't 
	-- relevant for this particular function 
    fix_up body | null void_tvs = body
		| otherwise	= mkTyApps (mkLams void_tvs body) 
					   (map (const voidTy) void_tvs)
    void_tvs = all_tvs \\ tvs

    msg = hang (ptext SLIT("Specialisation too complicated to desugar; ignored"))
	     2 (ppr spec_expr)
276 277
\end{code}

sof's avatar
sof committed
278

279 280 281 282 283 284 285
%************************************************************************
%*									*
\subsection{Adding inline pragmas}
%*									*
%************************************************************************

\begin{code}
286 287 288 289 290 291 292 293 294
decomposeRuleLhs :: [Var] -> CoreExpr -> Maybe ([Var], Id, [CoreExpr])
-- Returns Nothing if the LHS isn't of the expected shape
-- The argument 'all_bndrs' includes the "constant dicts" of the LHS,
-- and they may be GlobalIds, which we can't forall-ify. 
-- So we substitute them out instead
decomposeRuleLhs all_bndrs lhs 
  = go init_env (occurAnalyseExpr lhs)	-- Occurrence analysis sorts out the dict
					-- bindings so we know if they are recursive
  where
295

296 297 298 299 300 301 302 303 304 305 306 307 308 309 310
	-- all_bndrs may include top-level imported dicts, 
	-- imported things with a for-all.  
	-- So we localise them and subtitute them out
    bndr_prs =	[ (id, Var (localise id)) | id <- all_bndrs, isGlobalId id ]
    localise d = mkLocalId (idName d) (idType d)

    init_env = mkVarEnv bndr_prs
    all_bndrs' = map subst_bndr all_bndrs
    subst_bndr bndr = case lookupVarEnv init_env bndr of
			Just (Var bndr') -> bndr'
			Just other	 -> panic "decomposeRuleLhs"
			Nothing		 -> bndr

	-- Substitute dicts in the LHS args, so that there 
	-- aren't any lets getting in the way
311 312
	-- Note that we substitute the function too; we might have this as
	-- a LHS:	let f71 = M.f Int in f71
313 314 315
    go env (Let (NonRec dict rhs) body) 
	= go (extendVarEnv env dict (simpleSubst env rhs)) body
    go env body 
316 317
	= case collectArgs (simpleSubst env body) of
	    (Var fn, args) -> Just (all_bndrs', fn, args)
318 319 320 321 322 323 324 325 326 327 328 329
	    other 	   -> Nothing

simpleSubst :: IdEnv CoreExpr -> CoreExpr -> CoreExpr
-- Similar to CoreSubst.substExpr, except that 
-- (a) takes no account of capture; dictionary bindings use new names
-- (b) can have a GlobalId (imported) in its domain
-- (c) Ids only; no types are substituted

simpleSubst subst expr
  = go expr
  where
    go (Var v)	       = lookupVarEnv subst v `orElse` Var v
330
    go (Cast e co)     = Cast (go e) co
331 332 333 334 335 336 337 338 339 340
    go (Type ty)       = Type ty
    go (Lit lit)       = Lit lit
    go (App fun arg)   = App (go fun) (go arg)
    go (Note note e)   = Note note (go e)
    go (Lam bndr body) = Lam bndr (go body)
    go (Let (NonRec bndr rhs) body) = Let (NonRec bndr (go rhs)) (go body)
    go (Let (Rec pairs) body)       = Let (Rec (mapSnd go pairs)) (go body)
    go (Case scrut bndr ty alts)    = Case (go scrut) bndr ty 
					   [(c,bs,go r) | (c,bs,r) <- alts]

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
341 342 343 344 345 346
addInlinePrags :: [Prag] -> Id -> CoreExpr -> (Id,CoreExpr)
addInlinePrags prags bndr rhs
  = case [inl | InlinePrag inl <- prags] of
	[]      -> (bndr, rhs)
	(inl:_) -> addInlineInfo inl bndr rhs

347 348
addInlineInfo :: InlineSpec -> Id -> CoreExpr -> (Id,CoreExpr)
addInlineInfo (Inline phase is_inline) bndr rhs
349 350 351 352 353 354 355 356
  = (attach_phase bndr phase, wrap_inline is_inline rhs)
  where
    attach_phase bndr phase 
	| isAlwaysActive phase = bndr	-- Default phase
	| otherwise  	       = bndr `setInlinePragma` phase

    wrap_inline True  body = mkInlineMe body
    wrap_inline False body = body
357 358 359
\end{code}


sof's avatar
sof committed
360 361 362 363 364 365 366
%************************************************************************
%*									*
\subsection[addAutoScc]{Adding automatic sccs}
%*									*
%************************************************************************

\begin{code}
367 368 369 370 371 372 373 374 375 376 377 378 379 380
data AutoScc = NoSccs 
	     | AddSccs Module (Id -> Bool)
-- The (Id->Bool) says which Ids to add SCCs to 

addAutoScc :: AutoScc	
	   -> Id	-- Binder
	   -> CoreExpr 	-- Rhs
	   -> CoreExpr	-- Scc'd Rhs

addAutoScc NoSccs _ rhs
  = rhs
addAutoScc (AddSccs mod add_scc) id rhs
  | add_scc id = mkSCC (mkAutoCC id mod NotCafCC) rhs
  | otherwise  = rhs
sof's avatar
sof committed
381 382
\end{code}

383 384
If profiling and dealing with a dict binding,
wrap the dict in @_scc_ DICT <dict>@:
385 386

\begin{code}
387 388 389 390
addDictScc var rhs = returnDs rhs

{- DISABLED for now (need to somehow make up a name for the scc) -- SDM
  | not ( opt_SccProfilingOn && opt_AutoSccsOnDicts)
391
    || not (isDictId var)
sof's avatar
sof committed
392
  = returnDs rhs				-- That's easy: do nothing
393

sof's avatar
sof committed
394 395 396
  | otherwise
  = getModuleAndGroupDs 	`thenDs` \ (mod, grp) ->
	-- ToDo: do -dicts-all flag (mark dict things with individual CCs)
397
    returnDs (Note (SCC (mkAllDictsCC mod grp False)) rhs)
398
-}
399
\end{code}
400 401 402 403 404 405 406 407 408 409


%************************************************************************
%*									*
		Desugaring coercions
%*									*
%************************************************************************


\begin{code}
410 411 412 413
dsCoercion :: HsWrapper -> DsM CoreExpr -> DsM CoreExpr
dsCoercion WpHole 	     thing_inside = thing_inside
dsCoercion (WpCompose c1 c2) thing_inside = dsCoercion c1 (dsCoercion c2 thing_inside)
dsCoercion (WpCo co)     thing_inside = do { expr <- thing_inside
414
					       ; return (Cast expr co) }
415
dsCoercion (WpLam id)        thing_inside = do { expr <- thing_inside
416
					       ; return (Lam id expr) }
417
dsCoercion (WpTyLam tv)      thing_inside = do { expr <- thing_inside
418
					       ; return (Lam tv expr) }
419
dsCoercion (WpApp id)        thing_inside = do { expr <- thing_inside
420
					       ; return (App expr (Var id)) }
421
dsCoercion (WpTyApp ty)      thing_inside = do { expr <- thing_inside
422
					       ; return (App expr (Type ty)) }
423
dsCoercion (WpLet bs)        thing_inside = do { prs <- dsLHsBinds bs
424
					       ; expr <- thing_inside
425 426
					       ; return (Let (Rec prs) expr) }
\end{code}