CoreLift.lhs 8.94 KB
Newer Older
1
%
2
% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
3 4 5 6 7 8 9 10 11 12 13 14 15
%
\section[CoreLift]{Lifts unboxed bindings and any references to them}

\begin{code}
#include "HsVersions.h"

module CoreLift (
	liftCoreBindings,

	mkLiftedId,
	liftExpr,
	bindUnlift,
	applyBindUnlifts,
16 17
	isUnboxedButNotState

18 19
    ) where

20
import Ubiq{-uitous-}
21

22 23 24 25 26 27
import CoreSyn
import CoreUtils	( coreExprType )
import Id		( idType, mkSysLocal,
			  nullIdEnv, growIdEnvList, lookupIdEnv, IdEnv(..),
			  GenId{-instances-}
			)
28
import Name		( isLocallyDefined, getSrcLoc )
29
import PrelInfo		( liftDataCon, mkLiftTy, statePrimTyCon )
30
import TyCon		( isBoxedTyCon, TyCon{-instance-} )
31 32 33
import Type		( maybeAppDataTyCon, eqTy )
import UniqSupply	( getUnique, getUniques, splitUniqSupply, UniqSupply )
import Util		( zipEqual, zipWithEqual, assertPanic, panic )
34 35 36

infixr 9 `thenL`

37
updateIdType = panic "CoreLift.updateIdType"
38 39 40 41 42 43 44 45 46 47 48
\end{code}

%************************************************************************
%*									*
\subsection{``lift'' for various constructs}
%*									*
%************************************************************************

@liftCoreBindings@ is the top-level interface function.

\begin{code}
49 50 51
liftCoreBindings :: UniqSupply	-- unique supply
		 -> [CoreBinding]	-- unlifted bindings
		 -> [CoreBinding]	-- lifted bindings
52 53 54 55

liftCoreBindings us binds
  = initL (lift_top_binds binds) us
  where
56 57
    lift_top_binds [] = returnL []

58
    lift_top_binds (b:bs)
59
      = liftBindAndScope True b (
60
	  lift_top_binds bs `thenL` \ bs ->
61
	  returnL (ItsABinds bs)
62
	) 			`thenL` \ (b, ItsABinds bs) ->
63 64
	returnL (b:bs)

65 66 67 68 69 70

-----------------------
liftBindAndScope :: Bool		-- top level ?
		 -> CoreBinding		-- As yet unprocessed
		 -> LiftM BindsOrExpr	-- Do the scope of the bindings
		 -> LiftM (CoreBinding,	-- Processed
71 72 73 74
		 	   BindsOrExpr)

liftBindAndScope top_lev bind scopeM
  = liftBinders top_lev bind (
75 76 77 78
      liftCoreBind bind	`thenL` \ bind ->
      scopeM 		`thenL` \ bindsorexpr ->
      returnL (bind, bindsorexpr)
    )
79

80 81
-----------------------
liftCoreArg :: CoreArg -> LiftM (CoreArg, CoreExpr -> CoreExpr)
82

83 84 85 86
liftCoreArg arg@(TyArg     _) = returnL (arg, id)
liftCoreArg arg@(UsageArg  _) = returnL (arg, id)
liftCoreArg arg@(LitArg    _) = returnL (arg, id)
liftCoreArg arg@(VarArg v)
87 88
 = isLiftedId v			`thenL` \ lifted ->
    case lifted of
89 90
	Nothing -> returnL (arg, id)

91
	Just (lifted, unlifted) ->
92
	    returnL (VarArg unlifted, bindUnlift lifted unlifted)
93 94


95 96
-----------------------
liftCoreBind :: CoreBinding -> LiftM CoreBinding
97

98
liftCoreBind (NonRec b rhs)
99
  = liftOneBind (b,rhs)		`thenL` \ (b,rhs) ->
100
    returnL (NonRec b rhs)
101

102 103 104
liftCoreBind (Rec pairs)
  = mapL liftOneBind pairs	`thenL` \ pairs ->
    returnL (Rec pairs)
105

106
-----------------------
107 108 109 110 111 112 113
liftOneBind (binder,rhs)
  = liftCoreExpr rhs    	`thenL` \ rhs ->
    isLiftedId binder		`thenL` \ lifted ->
    case lifted of
	Just (lifted, unlifted) ->
	    returnL (lifted, liftExpr unlifted rhs)
	Nothing ->
114
	    returnL (binder, rhs)
115

116 117
-----------------------
liftCoreExpr :: CoreExpr -> LiftM CoreExpr
118

119
liftCoreExpr expr@(Var var)
120 121
  = isLiftedId var		`thenL` \ lifted ->
    case lifted of
122
	Nothing -> returnL expr
123
	Just (lifted, unlifted) ->
124
	    returnL (bindUnlift lifted unlifted (Var unlifted))
125

126
liftCoreExpr expr@(Lit lit) = returnL expr
127

128
liftCoreExpr (SCC label expr)
129
  = liftCoreExpr expr		`thenL` \ expr ->
130
    returnL (SCC label expr)
131

132 133 134 135
liftCoreExpr (Coerce coerce ty expr)
  = liftCoreExpr expr		`thenL` \ expr ->
    returnL (Coerce coerce ty expr) -- ToDo:right?:Coerce

136
liftCoreExpr (Let (NonRec binder rhs) body) -- special case: no lifting
137 138
  = liftCoreExpr rhs	`thenL` \ rhs ->
    liftCoreExpr body	`thenL` \ body ->
139
    returnL (mkCoLetUnboxedToCase (NonRec binder rhs) body)
140

141
liftCoreExpr (Let bind body)	-- general case
142
  = liftBindAndScope False bind (
143 144 145
      liftCoreExpr body	`thenL` \ body ->
      returnL (ItsAnExpr body)
    )				`thenL` \ (bind, ItsAnExpr body) ->
146
    returnL (Let bind body)
147

148 149 150
liftCoreExpr (Con con args)
  = mapAndUnzipL liftCoreArg args	`thenL` \ (args, unlifts) ->
    returnL (applyBindUnlifts unlifts (Con con args))
151

152 153 154
liftCoreExpr (Prim op args)
  = mapAndUnzipL liftCoreArg args	`thenL` \ (args, unlifts) ->
    returnL (applyBindUnlifts unlifts (Prim op args))
155

156
liftCoreExpr (App fun arg)
157 158
  = lift_app fun [arg]
  where
159
    lift_app (App fun arg) args
160 161 162
      = lift_app fun (arg:args)
    lift_app other_fun args
      = liftCoreExpr other_fun		`thenL` \ other_fun ->
163 164
	mapAndUnzipL liftCoreArg args	`thenL` \ (args, unlifts) ->
	returnL (applyBindUnlifts unlifts (mkGenApp other_fun args))
165

166
liftCoreExpr (Lam binder expr)
167
  = liftCoreExpr expr		`thenL` \ expr ->
168
    returnL (Lam binder expr)
169

170
liftCoreExpr (Case scrut alts)
171 172
 = liftCoreExpr scrut		`thenL` \ scrut ->
   liftCoreAlts alts		`thenL` \ alts ->
173
   returnL (Case scrut alts)
174

175 176
------------
liftCoreAlts :: CoreCaseAlts -> LiftM CoreCaseAlts
177

178
liftCoreAlts (AlgAlts alg_alts deflt)
179 180
 = mapL liftAlgAlt alg_alts	`thenL` \ alg_alts ->
   liftDeflt deflt		`thenL` \ deflt ->
181
   returnL (AlgAlts alg_alts deflt)
182

183
liftCoreAlts (PrimAlts prim_alts deflt)
184 185
 = mapL liftPrimAlt prim_alts	`thenL` \ prim_alts ->
   liftDeflt deflt		`thenL` \ deflt ->
186
   returnL (PrimAlts prim_alts deflt)
187

188
------------
189 190 191 192
liftAlgAlt (con,args,rhs)
  = liftCoreExpr rhs		`thenL` \ rhs ->
    returnL (con,args,rhs)

193
------------
194 195 196 197
liftPrimAlt (lit,rhs)
  = liftCoreExpr rhs		`thenL` \ rhs ->
    returnL (lit,rhs)

198 199 200 201 202 203
------------
liftDeflt NoDefault
  = returnL NoDefault
liftDeflt (BindDefault binder rhs)
  = liftCoreExpr rhs		`thenL` \ rhs ->
    returnL (BindDefault binder rhs)
204 205 206 207 208 209 210 211 212
\end{code}

%************************************************************************
%*									*
\subsection{Misc functions}
%*									*
%************************************************************************

\begin{code}
213 214 215 216 217 218 219 220
type LiftM a
  = IdEnv (Id, Id)	-- lifted Ids are mapped to:
			--   * lifted Id with the same Unique
			--     (top-level bindings must keep their
			--	unique (see TopLevId in Id.lhs))
			--   * unlifted version with a new Unique
    -> UniqSupply	-- unique supply
    -> a		-- result
221

222 223 224
data BindsOrExpr
  = ItsABinds [CoreBinding]
  | ItsAnExpr CoreExpr
225

226
initL m us = m nullIdEnv us
227 228

returnL :: a -> LiftM a
229
returnL r idenv us = r
230 231 232

thenL :: LiftM a -> (a -> LiftM b) -> LiftM b
thenL m k idenv s0
233 234
  = case (splitUniqSupply s0)	of { (s1, s2) ->
    case (m idenv s1)		of { r ->
235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251
    k r idenv s2 }}


mapL :: (a -> LiftM b) -> [a] -> LiftM [b]
mapL f [] = returnL []
mapL f (x:xs)
  = f x 		`thenL` \ r ->
    mapL f xs		`thenL` \ rs ->
    returnL (r:rs)

mapAndUnzipL  :: (a -> LiftM (b1, b2))	-> [a] -> LiftM ([b1],[b2])
mapAndUnzipL f [] = returnL ([],[])
mapAndUnzipL f (x:xs)
  = f x 		`thenL` \ (r1, r2) ->
    mapAndUnzipL f xs	`thenL` \ (rs1,rs2) ->
    returnL ((r1:rs1),(r2:rs2))

252
-- liftBinders is only called for top-level or recusive case
253
liftBinders :: Bool -> CoreBinding -> LiftM thing -> LiftM thing
254

255 256
liftBinders False (NonRec _ _) liftM idenv s0
  = panic "CoreLift:liftBinders"	-- should be caught by special case above
257

258
liftBinders top_lev bind liftM idenv s0
259
  = liftM (growIdEnvList idenv lift_map) s2
260
  where
261 262 263 264
    (s1, s2)   = splitUniqSupply s0
    lift_ids   = [ id | id <- bindersOf bind, isUnboxedButNotState (idType id) ]
    lift_uniqs = getUniques (length lift_ids) s1
    lift_map   = zipEqual lift_ids (zipWithEqual mkLiftedId lift_ids lift_uniqs)
265

266 267
    -- ToDo: Give warning for recursive bindings involving unboxed values ???

268 269
isLiftedId :: Id -> LiftM (Maybe (Id, Id))
isLiftedId id idenv us
270
  | isLocallyDefined id
271 272
     = lookupIdEnv idenv id
  | otherwise	-- ensure all imported ids are lifted
273 274
     = if isUnboxedButNotState (idType id)
       then Just (mkLiftedId id (getUnique us))
275 276 277 278
       else Nothing

mkLiftedId :: Id -> Unique -> (Id,Id)
mkLiftedId id u
279
  = ASSERT (isUnboxedButNotState unlifted_ty)
280 281
    (lifted_id, unlifted_id)
  where
282
    id_name     = panic "CoreLift.mkLiftedId:id_name" --LATER: getOccName id
283 284 285
    lifted_id   = updateIdType id lifted_ty
    unlifted_id = mkSysLocal id_name u unlifted_ty (getSrcLoc id)

286
    unlifted_ty = idType id
287 288
    lifted_ty   = mkLiftTy unlifted_ty

289
bindUnlift :: Id -> Id -> CoreExpr -> CoreExpr
290
bindUnlift vlift vunlift expr
291
  = ASSERT (isUnboxedButNotState unlift_ty)
292 293 294
    ASSERT (lift_ty `eqTy` mkLiftTy unlift_ty)
    Case (Var vlift)
	   (AlgAlts [(liftDataCon, [vunlift], expr)] NoDefault)
295
  where
296 297
    lift_ty   = idType vlift
    unlift_ty = idType vunlift
298

299
liftExpr :: Id -> CoreExpr -> CoreExpr
300
liftExpr vunlift rhs
301
  = ASSERT (isUnboxedButNotState unlift_ty)
302 303 304
    ASSERT (rhs_ty `eqTy` unlift_ty)
    Case rhs (PrimAlts []
	(BindDefault vunlift (mkCon liftDataCon [] [unlift_ty] [VarArg vunlift])))
305
  where
306 307
    rhs_ty    = coreExprType rhs
    unlift_ty = idType vunlift
308 309


310
applyBindUnlifts :: [CoreExpr -> CoreExpr] -> CoreExpr -> CoreExpr
311 312 313
applyBindUnlifts []     expr = expr
applyBindUnlifts (f:fs) expr = f (applyBindUnlifts fs expr)

314
isUnboxedButNotState ty
315
  = case (maybeAppDataTyCon ty) of
316 317 318 319
      Nothing -> False
      Just (tycon, _, _) ->
	not (isBoxedTyCon tycon) && not (tycon == statePrimTyCon)
\end{code}