HsCore.lhs 14.3 KB
Newer Older
1
%
2
% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
3 4 5 6 7 8 9 10
%
%************************************************************************
%*									*
\section[HsCore]{Core-syntax unfoldings in Haskell interface files}
%*									*
%************************************************************************

We could either use this, or parameterise @GenCoreExpr@ on @Types@ and
11
@TyVars@ as well.  Currently trying the former... MEGA SIGH.
12 13 14

\begin{code}
module HsCore (
15
	UfExpr(..), UfAlt, UfBinder(..), UfNote(..),
16
	UfBinding(..), UfConAlt(..),
sof's avatar
sof committed
17 18
	HsIdInfo(..), pprHsIdInfo,
	
19
	eq_ufExpr, eq_ufBinders, pprUfExpr, 
20

21
	toUfExpr, toUfBndr, ufBinderName
22 23
    ) where

24
#include "HsVersions.h"
25 26

-- friends:
27
import HsTypes		( HsType, pprParendHsType, pprHsTyVarBndr, toHsType,
28
			  HsTupCon(..), EqHsEnv, hsTupParens,
29
			  emptyEqHsEnv, extendEqHsEnv,
30
			  eq_hsType, eq_hsVars
31
			)
32 33

-- others:
34
import Id		( idArity, idType, isDataConWorkId_maybe, isFCallId_maybe )
35
import Var		( varType, isId )
36
import IdInfo		( InlinePragInfo )
37
import Name		( Name, NamedThing(..), eqNameByOcc )
38
import RdrName		( RdrName, rdrNameOcc )
39 40
import CoreSyn
import CostCentre	( pprCostCentreCore )
41
import NewDemand	( StrictSig, pprIfaceStrictSig )
42
import Literal		( Literal, maybeLitLit )
43
import ForeignCall	( ForeignCall )
44
import DataCon		( dataConTyCon, dataConSourceArity )
45
import TyCon		( isTupleTyCon, tupleTyConBoxity )
46
import Type		( Kind, eqKind )
47
import BasicTypes	( Arity )
48
import FiniteMap	( lookupFM )
sof's avatar
sof committed
49
import CostCentre
sof's avatar
sof committed
50
import Util		( eqListBy, lengthIs )
51
import Outputable
52
import FastString
53 54 55 56 57 58 59 60 61
\end{code}

%************************************************************************
%*									*
\subsection[HsCore-types]{Types for read/written Core unfoldings}
%*									*
%************************************************************************

\begin{code}
62 63
data UfExpr name
  = UfVar 	name
64
  | UfType      (HsType name)
65
  | UfTuple 	HsTupCon [UfExpr name]		-- Type arguments omitted
66 67
  | UfLam 	(UfBinder name)	(UfExpr name)
  | UfApp 	(UfExpr name)   (UfExpr name)
68
  | UfCase	(UfExpr name) name [UfAlt name]
69
  | UfLet	(UfBinding name)  (UfExpr name)
70
  | UfNote	(UfNote name) (UfExpr name)
71
  | UfLit	Literal
72
  | UfLitLit	FastString (HsType name)
73
  | UfFCall	ForeignCall (HsType name)
74

75 76 77
data UfNote name = UfSCC CostCentre
	         | UfCoerce (HsType name)
	         | UfInlineCall
78
	         | UfInlineMe
79
                 | UfCoreNote String
80

81
type UfAlt name = (UfConAlt name, [name], UfExpr name)
82

83 84
data UfConAlt name = UfDefault
 		   | UfDataAlt name
85
		   | UfTupleAlt HsTupCon
86
		   | UfLitAlt Literal
87
		   | UfLitLitAlt FastString (HsType name)
88 89 90 91 92 93 94 95 96

data UfBinding name
  = UfNonRec	(UfBinder name)
		(UfExpr name)
  | UfRec 	[(UfBinder name, UfExpr name)]

data UfBinder name
  = UfValBinder	name (HsType name)
  | UfTyBinder	name Kind
97 98 99 100

ufBinderName :: UfBinder name -> name
ufBinderName (UfValBinder n _) = n
ufBinderName (UfTyBinder  n _) = n
101 102
\end{code}

103

104 105
%************************************************************************
%*									*
106
\subsection{Converting from Core to UfCore}
107 108 109 110
%*									*
%************************************************************************

\begin{code}
111
toUfExpr :: CoreExpr -> UfExpr Name
112 113 114 115 116 117 118
toUfExpr (Var v) = toUfVar v
toUfExpr (Lit l) = case maybeLitLit l of
			Just (s,ty) -> UfLitLit s (toHsType ty)
			Nothing     -> UfLit l
toUfExpr (Type ty) = UfType (toHsType ty)
toUfExpr (Lam x b) = UfLam (toUfBndr x) (toUfExpr b)
toUfExpr (App f a) = toUfApp f [a]
119
toUfExpr (Case s x as) = UfCase (toUfExpr s) (getName x) (map toUfAlt as)
120 121 122 123 124 125 126 127
toUfExpr (Let b e)     = UfLet (toUfBind b) (toUfExpr e)
toUfExpr (Note n e)    = UfNote (toUfNote n) (toUfExpr e)

---------------------
toUfNote (SCC cc)	= UfSCC cc
toUfNote (Coerce t1 _)	= UfCoerce (toHsType t1)
toUfNote InlineCall	= UfInlineCall
toUfNote InlineMe	= UfInlineMe
128
toUfNote (CoreNote s)   = UfCoreNote s
129 130 131 132 133 134

---------------------
toUfBind (NonRec b r) = UfNonRec (toUfBndr b) (toUfExpr r)
toUfBind (Rec prs)    = UfRec [(toUfBndr b, toUfExpr r) | (b,r) <- prs]

---------------------
135
toUfAlt (c,bs,r) = (toUfCon c, map getName bs, toUfExpr r)
136 137

---------------------
138
toUfCon (DataAlt dc) | isTupleTyCon tc = UfTupleAlt (mk_hs_tup_con tc dc)
139
		     | otherwise       = UfDataAlt (getName dc)
140 141 142 143 144 145 146 147
		     where
		       tc = dataConTyCon dc

toUfCon (LitAlt l)   = case maybeLitLit l of
			 Just (s,ty) -> UfLitLitAlt s (toHsType ty)
			 Nothing     -> UfLitAlt l
toUfCon DEFAULT	     = UfDefault

148
---------------------
149
mk_hs_tup_con tc dc = HsTupCon (tupleTyConBoxity tc) (dataConSourceArity dc)
150

151
---------------------
152 153
toUfBndr x | isId x    = UfValBinder (getName x) (toHsType (varType x))
	   | otherwise = UfTyBinder  (getName x) (varType x)
154 155 156 157

---------------------
toUfApp (App f a) as = toUfApp f (a:as)
toUfApp (Var v) as
158
  = case isDataConWorkId_maybe v of
159
	-- We convert the *worker* for tuples into UfTuples
160
	Just dc |  isTupleTyCon tc && saturated 
161
		-> UfTuple (mk_hs_tup_con tc dc) tup_args
162 163
	  where
	    val_args  = dropWhile isTypeArg as
sof's avatar
sof committed
164
	    saturated = val_args `lengthIs` idArity v
165 166 167 168 169 170 171 172 173 174 175
	    tup_args  = map toUfExpr val_args
	    tc	      = dataConTyCon dc
	;

        other -> mkUfApps (toUfVar v) as

toUfApp e as = mkUfApps (toUfExpr e) as

mkUfApps = foldl (\f a -> UfApp f (toUfExpr a))

---------------------
176 177 178 179
toUfVar v = case isFCallId_maybe v of
		-- Foreign calls have special syntax
		Just fcall -> UfFCall fcall (toHsType (idType v))
		other	   -> UfVar (getName v)
180
\end{code}
181

182

183 184 185 186 187
%************************************************************************
%*									*
\subsection[HsCore-print]{Printing Core unfoldings}
%*									*
%************************************************************************
188

189
\begin{code}
190
instance OutputableBndr name => Outputable (UfExpr name) where
191 192
    ppr e = pprUfExpr noParens e

193 194 195 196 197 198 199 200

-- Small-hack alert: this instance allows us to do a getOccName on RdrNames.
-- Important because we want to pretty-print UfExprs, and we have to
-- print an '@' before tyvar-binders in a case alternative.
instance NamedThing RdrName where
    getOccName n = rdrNameOcc n
    getName n	 = pprPanic "instance NamedThing RdrName" (ppr n)

201 202 203
noParens :: SDoc -> SDoc
noParens pp = pp

204
pprUfExpr :: OutputableBndr name => (SDoc -> SDoc) -> UfExpr name -> SDoc
205 206 207 208 209
	-- The function adds parens in context that need
	-- an atomic value (e.g. function args)

pprUfExpr add_par (UfVar v)       = ppr v
pprUfExpr add_par (UfLit l)       = ppr l
210
pprUfExpr add_par (UfLitLit l ty) = add_par (hsep [ptext SLIT("__litlit"), pprHsString l, pprParendHsType ty])
211
pprUfExpr add_par (UfFCall cc ty) = braces (ppr cc <+> ppr ty)
212
pprUfExpr add_par (UfType ty)     = char '@' <+> pprParendHsType ty
213

214
pprUfExpr add_par e@(UfLam _ _)   = add_par (char '\\' <+> hsep (map (pprBndr LambdaBind) bndrs)
215 216
                                             <+> ptext SLIT("->") <+> pprUfExpr noParens body)
                                  where (bndrs,body) = collectUfBndrs e
217
pprUfExpr add_par app@(UfApp _ _) = add_par (pprUfApp app)
218 219 220 221 222 223 224
pprUfExpr add_par (UfTuple c as)  = hsTupParens c (interpp'SP as)

pprUfExpr add_par (UfCase scrut bndr alts)
      = add_par (hsep [ptext SLIT("case"), pprUfExpr noParens scrut, ptext SLIT("of"), ppr bndr,
		       braces (hsep (map pp_alt alts))])
      where
	pp_alt (UfTupleAlt tup_con, bs, rhs) = hsTupParens tup_con (interpp'SP bs) <+> ppr_rhs rhs
225
	pp_alt (c,		    bs, rhs) = ppr c <+> hsep (map (pprBndr CaseBind) bs) <+> ppr_rhs rhs
226

227
        ppr_rhs rhs = ptext SLIT("->") <+> pprUfExpr noParens rhs <> semi
228

229 230
pprUfExpr add_par (UfLet (UfNonRec b rhs) body)
      = add_par (hsep [ptext SLIT("let"), 
231
		       braces (pprBndr LetBind b <+> equals <+> pprUfExpr noParens rhs), 
232
		       ptext SLIT("in"), pprUfExpr noParens body])
233

234 235 236
pprUfExpr add_par (UfLet (UfRec pairs) body)
      = add_par (hsep [ptext SLIT("__letrec"), braces (hsep (map pp_pair pairs)), 
		       ptext SLIT("in"), pprUfExpr noParens body])
237
      where
238
	pp_pair (b,rhs) = ppr b <+> equals <+> pprUfExpr noParens rhs <> semi
239

240
pprUfExpr add_par (UfNote note body) = add_par (ppr note <+> pprUfExpr parens body)
241

242 243
pprUfApp (UfApp fun arg) = pprUfApp fun <+> pprUfExpr parens arg
pprUfApp fun	         = pprUfExpr parens fun
244

245 246 247 248 249 250 251
collectUfBndrs :: UfExpr name -> ([UfBinder name], UfExpr name)
collectUfBndrs expr
  = go [] expr
  where
    go bs (UfLam b e) = go (b:bs) e
    go bs e           = (reverse bs, e)

252 253 254 255 256
instance Outputable name => Outputable (UfNote name) where
    ppr (UfSCC cc)    = pprCostCentreCore cc
    ppr (UfCoerce ty) = ptext SLIT("__coerce") <+> pprParendHsType ty
    ppr UfInlineCall  = ptext SLIT("__inline_call")
    ppr UfInlineMe    = ptext SLIT("__inline_me")
257
    ppr (UfCoreNote s)= ptext SLIT("__core_note") <+> pprHsString (mkFastString s)
258

259
instance Outputable name => Outputable (UfConAlt name) where
260
    ppr UfDefault	   = text "__DEFAULT"
261
    ppr (UfLitAlt l)       = ppr l
262
    ppr (UfLitLitAlt l ty) = parens (hsep [ptext SLIT("__litlit"), pprHsString l, pprParendHsType ty])
263
    ppr (UfDataAlt d)	   = ppr d
264 265

instance Outputable name => Outputable (UfBinder name) where
266 267
    ppr (UfValBinder name ty)  = hsep [ppr name, dcolon, pprParendHsType ty]
    ppr (UfTyBinder name kind) = char '@' <+> pprHsTyVarBndr name kind
268 269 270 271

instance OutputableBndr name => OutputableBndr (UfBinder name) where
    pprBndr _ (UfValBinder name ty)  = hsep [ppr name, dcolon, pprParendHsType ty]
    pprBndr _ (UfTyBinder name kind) = char '@' <+> pprHsTyVarBndr name kind
272 273 274 275 276 277 278 279 280
\end{code}


%************************************************************************
%*									*
\subsection[HsCore-print]{Equality, for interface file checking
%*									*
%************************************************************************

281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298
	----------------------------------------
			HACK ALERT
	----------------------------------------

Whe comparing UfExprs, we compare names by converting to RdrNames and comparing
those.  Reason: this is used when comparing ufoldings in interface files, and the
uniques can differ.  Converting to RdrNames makes it more like comparing the file
contents directly.  But this is bad: version numbers can change when only alpha-conversion
has happened. 

	The hack shows up in eq_ufVar
	There are corresponding getOccName calls in MkIface.diffDecls

	----------------------------------------
			END OF HACK ALERT
	----------------------------------------


299
\begin{code}
300
instance (NamedThing name, Ord name) => Eq (UfExpr name) where
301 302 303 304 305 306
  (==) a b = eq_ufExpr emptyEqHsEnv a b

-----------------
eq_ufBinder env (UfValBinder n1 t1) (UfValBinder n2 t2) k
  = eq_hsType env t1 t2 && k (extendEqHsEnv env n1 n2)
eq_ufBinder env (UfTyBinder n1 k1) (UfTyBinder n2 k2) k
307
  = k1 `eqKind` k2 && k (extendEqHsEnv env n1 n2)
308 309 310 311 312 313 314 315
eq_ufBinder _ _ _ _ = False

-----------------
eq_ufBinders env []       []	   k = k env
eq_ufBinders env (b1:bs1) (b2:bs2) k = eq_ufBinder env b1 b2 (\env -> eq_ufBinders env bs1 bs2 k)
eq_ufBinders env _	  _	   _ = False

-----------------
316 317 318 319
eq_ufVar :: (NamedThing name, Ord name) => EqHsEnv name -> name -> name -> Bool
-- Compare *Rdr* names.  A real hack to avoid gratuitous 
-- differences when comparing interface files
eq_ufVar env n1 n2 = case lookupFM env n1 of
320 321 322 323
		       Just n1 -> check n1
		       Nothing -> check n2
   where
	check n1 = eqNameByOcc (getName n1) (getName n2)
324 325 326 327

-----------------
eq_ufExpr :: (NamedThing name, Ord name) => EqHsEnv name -> UfExpr name -> UfExpr name -> Bool
eq_ufExpr env (UfVar v1)	(UfVar v2)	  = eq_ufVar env v1 v2
328 329
eq_ufExpr env (UfLit l1)        (UfLit l2) 	  = l1 == l2
eq_ufExpr env (UfLitLit l1 ty1) (UfLitLit l2 ty2) = l1==l2 && eq_hsType env ty1 ty2
330
eq_ufExpr env (UfFCall c1 ty1)  (UfFCall c2 ty2)  = c1==c2 && eq_hsType env ty1 ty2
331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358
eq_ufExpr env (UfType ty1)      (UfType ty2)	  = eq_hsType env ty1 ty2
eq_ufExpr env (UfTuple n1 as1)  (UfTuple n2 as2)  = n1==n2 && eqListBy (eq_ufExpr env) as1 as2
eq_ufExpr env (UfLam b1 body1)  (UfLam b2 body2)  = eq_ufBinder env b1 b2 (\env -> eq_ufExpr env body1 body2)
eq_ufExpr env (UfApp f1 a1)     (UfApp f2 a2)	  = eq_ufExpr env f1 f2 && eq_ufExpr env a1 a2

eq_ufExpr env (UfCase s1 b1 as1) (UfCase s2 b2 as2)
  = eq_ufExpr env s1 s2 && 
    eqListBy (eq_ufAlt (extendEqHsEnv env b1 b2)) as1 as2
  where
    eq_ufAlt env (c1,bs1,r1) (c2,bs2,r2)
	= eq_ufConAlt env c1 c2 && eq_hsVars env bs1 bs2 (\env -> eq_ufExpr env r1 r2)

eq_ufExpr env (UfLet (UfNonRec b1 r1) x1) (UfLet (UfNonRec b2 r2) x2)
  = eq_ufExpr env r1 r2 && eq_ufBinder env b1 b2 (\env -> eq_ufExpr env x1 x2)

eq_ufExpr env (UfLet (UfRec as1) x1) (UfLet (UfRec as2) x2)
  = eq_ufBinders env bs1 bs2 (\env -> eqListBy (eq_ufExpr env) rs1 rs2 && eq_ufExpr env x1 x2)
  where
    (bs1,rs1) = unzip as1
    (bs2,rs2) = unzip as2

eq_ufExpr env (UfNote n1 r1) (UfNote n2 r2)
  = eq_ufNote n1 n2 && eq_ufExpr env r1 r2
  where
    eq_ufNote (UfSCC c1)    (UfSCC c2)    = c1==c2 
    eq_ufNote (UfCoerce t1) (UfCoerce t2) = eq_hsType env t1 t2
    eq_ufNote UfInlineCall  UfInlineCall  = True
    eq_ufNote UfInlineMe    UfInlineMe    = True
359
    eq_ufNote (UfCoreNote s1) (UfCoreNote s2) = s1==s2
360 361 362 363 364 365 366 367 368 369 370
    eq_ufNote _		    _		  = False

eq_ufExpr env _ _ = False

-----------------
eq_ufConAlt env UfDefault	    UfDefault		= True
eq_ufConAlt env (UfDataAlt n1)	    (UfDataAlt n2)	= n1==n2
eq_ufConAlt env (UfTupleAlt c1)	    (UfTupleAlt c2)	= c1==c2
eq_ufConAlt env (UfLitAlt l1)	    (UfLitAlt l2)	= l1==l2
eq_ufConAlt env (UfLitLitAlt s1 t1) (UfLitLitAlt s2 t2) = s1==s2 && eq_hsType env t1 t2
eq_ufConAlt env _ _ = False
371 372
\end{code}

373

374 375 376 377 378 379 380
%************************************************************************
%*									*
\subsection{Rules in interface files}
%*									*
%************************************************************************

\begin{code}
381
pprHsIdInfo :: OutputableBndr n => [HsIdInfo n] -> SDoc
382
pprHsIdInfo []   = empty
383
pprHsIdInfo info = ptext SLIT("{-##") <+> hsep (map ppr_hs_info info) <+> ptext SLIT("##-}")
384 385

data HsIdInfo name
386
  = HsArity		Arity
387
  | HsStrictness	StrictSig
388
  | HsUnfold		InlinePragInfo (UfExpr name)
389
  | HsNoCafRefs
390 391
  | HsWorker		name Arity	-- Worker, if any see IdInfo.WorkerInfo
					-- for why we want arity here.
392 393 394
  deriving( Eq )
-- NB: Specialisations and rules come in separately and are
-- only later attached to the Id.  Partial reason: some are orphans.
395

396
ppr_hs_info (HsUnfold prag unf) = ptext SLIT("__U") <> ppr prag <+> parens (pprUfExpr noParens unf)
397
ppr_hs_info (HsArity arity)     = ptext SLIT("__A") <+> int arity
398
ppr_hs_info (HsStrictness str)  = ptext SLIT("__S") <+> pprIfaceStrictSig str
399
ppr_hs_info HsNoCafRefs		= ptext SLIT("__C")
400
ppr_hs_info (HsWorker w a)	= ptext SLIT("__P") <+> ppr w <+> int a
401 402
\end{code}