MkIface.lhs 23 KB
Newer Older
1
%
2
% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
3
4
5
6
%
\section[MkIface]{Print an interface for a module}

\begin{code}
7
module MkIface ( writeIface  ) where
8

9
10
#include "HsVersions.h"

11
import IO		( openFile, hClose, IOMode(..) )
12
13

import HsSyn
14
15
16
17
import HsCore		( HsIdInfo(..), toUfExpr )
import RdrHsSyn		( RdrNameRuleDecl )
import HsPragmas	( DataPragmas(..), ClassPragmas(..) )
import HsTypes		( toHsTyVars )
18
import BasicTypes	( Fixity(..), NewOrData(..),
19
			  Version, bumpVersion, initialVersion, isLoopBreaker
20
			)
21
22
23
24
25
import RnMonad

import TcInstUtil	( InstInfo(..) )

import CmdLineOpts
26
import Id		( Id, idType, idInfo, omitIfaceSigForId, isUserExportedId, hasNoBinding,
27
			  idSpecialisation
28
			)
29
30
import Var		( isId )
import VarSet
31
import DataCon		( StrictnessMark(..), dataConSig, dataConFieldLabels, dataConStrictMarks )
32
import IdInfo		( IdInfo, StrictnessInfo(..), ArityInfo(..), 
33
34
35
36
			  CprInfo(..), CafInfo(..),
			  inlinePragInfo, arityInfo, arityLowerBound,
			  strictnessInfo, isBottomingStrictness,
			  cafInfo, specInfo, cprInfo, 
37
			  occInfo, isNeverInlinePrag,
38
			  workerInfo, WorkerInfo(..)
39
			)
40
import CoreSyn		( CoreExpr, CoreBind, Bind(..), isBuiltinRule, rulesRules, rulesRhsFreeVars )
41
import CoreFVs		( exprSomeFreeVars, ruleSomeLhsFreeVars, ruleSomeFreeVars )
42
import CoreUnfold	( okToUnfoldInHiFile, couldBeSmallEnoughToInline )
43
import Module		( pprModuleName, moduleUserString )
44
import Name		( isLocallyDefined, isWiredInName, toRdrName, nameModule,
45
			  Name, NamedThing(..)
46
			)
sof's avatar
sof committed
47
import OccName		( OccName, pprOccName )
48
import TyCon		( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon,
49
			  tyConTheta, tyConTyVars, tyConDataCons, tyConFamilySize
50
			)
51
52
import Class		( classExtraBigSig )
import FieldLabel	( fieldLabelType )
53
import Type		( mkSigmaTy, splitSigmaTy, mkDictTy, tidyTopType,
54
			  deNoteType, classesToPreds
sof's avatar
sof committed
55
		        )
56

57
import Rules		( ProtoCoreRule(..) )
58

59
import Bag		( bagToList )
60
import UniqFM		( lookupUFM, listToUFM )
61
import Util		( sortLt )
62
import SrcLoc		( noSrcLoc )
63
import Bag
64
import Outputable
65
import ErrUtils		( dumpIfSet )
66
67

import Maybe 		( isNothing )
68
import List		( partition )
69
import Monad 		( when )
70
71
72
\end{code}


73
74
75
76
77
%************************************************************************
%*				 					*
\subsection{Write a new interface file}
%*				 					*
%************************************************************************
78

79
\begin{code}
80
81
82
writeIface this_mod old_iface new_iface
	   local_tycons local_classes inst_info
	   final_ids tidy_binds tidy_orphan_rules
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
  = 
    if isNothing opt_HiDir && isNothing opt_HiFile
	then return ()  -- not producing any .hi file
	else 

    let 
	hi_suf = case opt_HiSuf of { Nothing -> "hi"; Just suf -> suf }
	filename = case opt_HiFile of {
			Just f  -> f;
			Nothing -> 
		   case opt_HiDir of {
			Just dir -> dir ++ '/':moduleUserString this_mod 
					++ '.':hi_suf;
			Nothing  -> panic "writeIface"
		}}
    in
99

100
101
102
103
    do maybe_final_iface <- checkIface old_iface full_new_iface 	
       case maybe_final_iface of {
	  Nothing -> when opt_D_dump_rn_trace $
		     putStrLn "Interface file unchanged" ;  -- No need to update .hi file
104

105
	  Just final_iface ->
106

107
       do  let mod_vers_unchanged = case old_iface of
108
109
				   Just iface -> pi_vers iface == pi_vers final_iface
				   Nothing -> False
110
111
     	   when (mod_vers_unchanged && opt_D_dump_rn_trace) $
	        putStrLn "Module version unchanged, but usages differ; hence need new hi file"
112

113
114
115
	   if_hdl <- openFile filename WriteMode
	   printForIface if_hdl (pprIface final_iface)
	   hClose if_hdl
116
    }   
117
118
119
120
121
  where
    full_new_iface = completeIface new_iface local_tycons local_classes
				   	     inst_info final_ids tidy_binds
					     tidy_orphan_rules
\end{code}
122
123


124
125
126
127
128
%************************************************************************
%*				 					*
\subsection{Checking if the new interface is up to date
%*				 					*
%************************************************************************
129
130

\begin{code}
131
132
checkIface :: Maybe ParsedIface		-- The old interface, read from M.hi
	   -> ParsedIface		-- The new interface; but with all version numbers = 1
133
	   -> IO (Maybe ParsedIface)	-- Nothing => no change; no need to write new Iface
134
135
					-- Just pi => Here is the new interface to write
					-- 	      with correct version numbers
136
		-- The I/O part is just so it can print differences
137
138
139
140
141
142
143

-- NB: the fixities, declarations, rules are all assumed
-- to be sorted by increasing order of hsDeclName, so that 
-- we can compare for equality

checkIface Nothing new_iface
-- No old interface, so definitely write a new one!
144
  = return (Just new_iface)
145
146
147

checkIface (Just iface) new_iface
  | no_output_change && no_usage_change
148
  = return Nothing
149
150

  | otherwise		-- Add updated version numbers
151
  = do { dumpIfSet opt_D_dump_hi_diffs "Interface file changes" pp_diffs ;
152
	 return (Just final_iface )}
153
	
154
  where
155
156
157
158
159
    final_iface = new_iface { pi_vers = new_mod_vers,
		      	      pi_fixity = (new_fixity_vers, new_fixities),
		      	      pi_rules  = (new_rules_vers,  new_rules),
		      	      pi_decls  = final_decls }

160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
    no_usage_change = pi_usages iface == pi_usages new_iface

    no_output_change = no_decl_changed && 
	               new_fixity_vers == fixity_vers && 
	               new_rules_vers == rules_vers &&
	               no_export_change

    no_export_change = pi_exports iface == pi_exports new_iface

    new_mod_vers | no_output_change = mod_vers
		 | otherwise  	    = bumpVersion mod_vers

    mod_vers = pi_vers iface

    (fixity_vers, fixities) = pi_fixity iface
    (_,       new_fixities) = pi_fixity new_iface
    new_fixity_vers | fixities == new_fixities = fixity_vers
		    | otherwise		       = bumpVersion fixity_vers

    (rules_vers, rules) = pi_rules iface
    (_,      new_rules) = pi_rules new_iface
    new_rules_vers  | rules == new_rules = rules_vers
		    | otherwise		 = bumpVersion rules_vers

184
    (no_decl_changed, pp_diffs, final_decls) = merge_decls True empty [] (pi_decls iface) (pi_decls new_iface)
185
186
187
188
189

	-- Fill in the version number on the new declarations
	-- by looking at the old declarations.
	-- Set the flag if anything changes. 
	-- Assumes that the decls are sorted by hsDeclName
190
191
192
193
    merge_decls ok_so_far pp acc []  []        = (ok_so_far, pp, reverse acc)
    merge_decls ok_so_far pp acc old []        = (False,     pp, reverse acc)
    merge_decls ok_so_far pp acc [] (nvd:nvds) = merge_decls False (pp $$ only_new nvd) (nvd:acc) [] nvds
    merge_decls ok_so_far pp acc (vd@(v,d):vds) (nvd@(_,nd):nvds)
194
	= case d_name `compare` nd_name of
195
196
197
198
		LT -> merge_decls False (pp $$ only_old vd)  acc       vds      (nvd:nvds)
		GT -> merge_decls False (pp $$ only_new nvd) (nvd:acc) (vd:vds) nvds
		EQ | d == nd   -> merge_decls ok_so_far pp 		     (vd:acc) 		       vds nvds
		   | otherwise -> merge_decls False	(pp $$ changed d nd) ((bumpVersion v, nd):acc) vds nvds
199
200
201
	where
 	  d_name  = hsDeclName d
 	  nd_name = hsDeclName nd
202
203
204
205
206

    only_old (_,d) = ptext SLIT("Only in old iface:") <+> ppr d
    only_new (_,d) = ptext SLIT("Only in new iface:") <+> ppr d
    changed d nd   = ptext SLIT("Changed in iface: ") <+> ((ptext SLIT("Old:") <+> ppr d) $$ 
							   (ptext SLIT("New:") <+> ppr nd))
207
208
209
210
211
212
213
214
215
\end{code}



%************************************************************************
%*				 					*
\subsection{Printing the interface}
%*				 					*
%************************************************************************
216

217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
\begin{code}
pprIface (ParsedIface { pi_mod = mod, pi_vers = mod_vers, pi_orphan = orphan,
			pi_usages = usages, pi_exports = exports, 
			pi_fixity = (fix_vers, fixities),
			pi_insts = insts, pi_decls = decls, 
			pi_rules = (rule_vers, rules), pi_deprecs = deprecs })
 = vcat [ ptext SLIT("__interface")
		<+> doubleQuotes (ptext opt_InPackage)
		<+> ppr mod <+> ppr mod_vers <+> pp_sub_vers
		<+> (if orphan then char '!' else empty)
		<+> int opt_HiVersion
		<+> ptext SLIT("where")
	, vcat (map pprExport exports)
	, vcat (map pprUsage usages)
	, pprFixities fixities
	, vcat [ppr i <+> semi | i <- insts]
	, vcat [ppr_vers v <+> ppr d <> semi | (v,d) <- decls]
	, pprRules rules
	, pprDeprecs deprecs
	]
  where
    ppr_vers v | v == initialVersion = empty
	       | otherwise	     = int v
    pp_sub_vers 
	| fix_vers == initialVersion && rule_vers == initialVersion = empty
	| otherwise = brackets (ppr fix_vers <+> ppr rule_vers)
243
244
\end{code}

245
246
247
248
When printing export lists, we print like this:
	Avail   f		f
	AvailTC C [C, x, y]	C(x,y)
	AvailTC C [x, y]	C!(x,y)		-- Exporting x, y but not C
249

250
\begin{code}
251
252
253
pprExport :: ExportItem -> SDoc
pprExport (mod, items)
 = hsep [ ptext SLIT("__export "), ppr mod, hsep (map upp_avail items) ] <> semi
sof's avatar
sof committed
254
  where
255
256
257
258
259
260
261
262
263
264
265
    upp_avail :: RdrAvailInfo -> SDoc
    upp_avail (Avail name)      = pprOccName name
    upp_avail (AvailTC name []) = empty
    upp_avail (AvailTC name ns) = hcat [pprOccName name, bang, upp_export ns']
				where
				  bang | name `elem` ns = empty
				       | otherwise	= char '|'
				  ns' = filter (/= name) ns
    
    upp_export []    = empty
    upp_export names = braces (hsep (map pprOccName names))
266
267
\end{code}

268

269
\begin{code}
270
271
272
273
274
275
pprUsage :: ImportVersion OccName -> SDoc
pprUsage (m, has_orphans, is_boot, whats_imported)
  = hsep [ptext SLIT("import"), pprModuleName m, 
	  pp_orphan, pp_boot,
	  upp_import_versions whats_imported
    ] <> semi
276
  where
277
278
279
280
    pp_orphan | has_orphans = char '!'
	      | otherwise   = empty
    pp_boot   | is_boot     = char '@'
              | otherwise   = empty
281

282
	-- Importing the whole module is indicated by an empty list
283
284
285
286
287
    upp_import_versions NothingAtAll   = empty
    upp_import_versions (Everything v) = dcolon <+> int v
    upp_import_versions (Specifically vm vf vr nvs)
      = dcolon <+> int vm <+> int vf <+> int vr <+> hsep [ ppr n <+> int v | (n,v) <- nvs ]
\end{code}
288

289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318

\begin{code}
pprFixities []    = empty
pprFixities fixes = hsep (map ppr fixes) <> semi

pprRules []    = empty
pprRules rules = hsep [ptext SLIT("{-## __R"), hsep (map ppr rules), ptext SLIT("##-}")]

pprDeprecs []   = empty
pprDeprecs deps = hsep [ ptext SLIT("{-## __D"), guts, ptext SLIT("##-}")]
		where
		  guts = hsep [ ppr ie <+> doubleQuotes (ppr txt) <> semi 
			      | Deprecation ie txt _ <- deps ]
\end{code}


%************************************************************************
%*				 					*
\subsection{Completing the new interface}
%*				 					*
%************************************************************************

\begin{code}
completeIface new_iface local_tycons local_classes
		        inst_info final_ids tidy_binds
			tidy_orphan_rules
  = new_iface { pi_decls = [(initialVersion,d) | d <- sortLt lt_decl all_decls],
		pi_insts = sortLt lt_inst_decl inst_dcls,
		pi_rules = (initialVersion, rule_dcls)
    }
319
  where
320
321
322
     all_decls = cls_dcls ++ ty_dcls ++ bagToList val_dcls
     (inst_dcls, inst_ids) = ifaceInstances inst_info
     cls_dcls = map ifaceClass local_classes
323
  
324
325
326
327
328
329
330
331
332
333
334
     ty_dcls  = map ifaceTyCon (filter (not . isWiredInName . getName) local_tycons)

     (val_dcls, emitted_ids) = ifaceBinds (inst_ids `unionVarSet` orphan_rule_ids)
					  final_ids tidy_binds

     rule_dcls | opt_OmitInterfacePragmas = []
	       | otherwise		  = ifaceRules tidy_orphan_rules emitted_ids

     orphan_rule_ids = unionVarSets [ ruleSomeFreeVars interestingId rule 
				    | ProtoCoreRule _ _ rule <- tidy_orphan_rules]

335
336
337
lt_decl      d1 d2 = hsDeclName   d1 < hsDeclName d2
lt_inst_decl d1 d2 = instDeclName d1 < instDeclName d2
	-- Even instance decls have names, namely the dfun name
338
\end{code}
339

340

341
342
%************************************************************************
%*				 					*
343
\subsection{Completion stuff}
344
345
%*				 					*
%************************************************************************
346

347
348
349
350
351
352
353
354
355
356
357
358
359
\begin{code}
ifaceRules :: [ProtoCoreRule] -> IdSet -> [RdrNameRuleDecl]
ifaceRules rules emitted
  = orphan_rules ++ local_rules
  where
    orphan_rules = [ toHsRule fn rule | ProtoCoreRule _ fn rule <- rules ]
    local_rules  = [ toHsRule fn rule
 		   | fn <- varSetElems emitted, 
		     rule <- rulesRules (idSpecialisation fn),
		     not (isBuiltinRule rule),
				-- We can't print builtin rules in interface files
				-- Since they are built in, an importing module
				-- will have access to them anyway
360
361
362
363

			-- Sept 00: I've disabled this test.  It doesn't stop many, if any, rules
			-- from coming out, and to make it work properly we need to add 
			     all (`elemVarSet` emitted) (varSetElems (ruleSomeLhsFreeVars interestingId rule))
364
365
366
367
				-- Spit out a rule only if all its lhs free vars are emitted
				-- This is a good reason not to do it when we emit the Id itself
		   ]
\end{code}
368
369

\begin{code}			 
370
371
372
373
374
375
376
ifaceInstances :: Bag InstInfo -> ([RdrNameInstDecl], IdSet)
		   -- The IdSet is the needed dfuns

ifaceInstances inst_infos
  = (decls, needed_ids)
  where			
    decls       = map to_decl togo_insts
377
    togo_insts	= filter is_togo_inst (bagToList inst_infos)
378
379
    needed_ids  = mkVarSet [dfun_id | InstInfo _ _ _ _ dfun_id _ _ _ <- togo_insts]
    is_togo_inst (InstInfo _ _ _ _ dfun_id _ _ _) = isLocallyDefined dfun_id
380
381
				 
    -------			 
382
    to_decl (InstInfo clas tvs tys theta dfun_id _ _ _)
383
      = let			 
384
385
386
387
388
389
390
391
392
		-- The deNoteType is very important.   It removes all type
		-- synonyms from the instance type in interface files.
		-- That in turn makes sure that when reading in instance decls
		-- from interface files that the 'gating' mechanism works properly.
		-- Otherwise you could have
		--	type Tibble = T Int
		--	instance Foo Tibble where ...
		-- and this instance decl wouldn't get imported into a module
		-- that mentioned T but not Tibble.
393
394
	    forall_ty     = mkSigmaTy tvs (classesToPreds theta)
				      (deNoteType (mkDictTy clas tys))
395
	    tidy_ty = tidyTopType forall_ty
396
	in			 
397
	InstDecl (toHsType tidy_ty) EmptyMonoBinds [] (Just (toRdrName dfun_id)) noSrcLoc 
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
\end{code}

\begin{code}
ifaceTyCon :: TyCon -> RdrNameHsDecl
ifaceTyCon tycon
  | isSynTyCon tycon
  = TyClD (TySynonym (toRdrName tycon)
		     (toHsTyVars tyvars) (toHsType ty)
		     noSrcLoc)
  where
    (tyvars, ty) = getSynTyConDefn tycon

ifaceTyCon tycon
  | isAlgTyCon tycon
  = TyClD (TyData new_or_data (toHsContext (tyConTheta tycon))
		  (toRdrName tycon)
		  (toHsTyVars tyvars)
		  (map ifaceConDecl (tyConDataCons tycon))
		  (tyConFamilySize tycon)
		  Nothing NoDataPragmas noSrcLoc)
  where
    tyvars = tyConTyVars tycon
    new_or_data | isNewTyCon tycon = NewType
	        | otherwise	   = DataType

    ifaceConDecl data_con 
	= ConDecl (toRdrName data_con) (error "ifaceConDecl")
		  (toHsTyVars ex_tyvars)
		  (toHsContext ex_theta)
		  details noSrcLoc
	where
	  (tyvars1, _, ex_tyvars, ex_theta, arg_tys, tycon1) = dataConSig data_con
          field_labels   = dataConFieldLabels data_con
          strict_marks   = dataConStrictMarks data_con
	  details
	    | null field_labels
	    = ASSERT( tycon == tycon1 && tyvars == tyvars1 )
	      VanillaCon (zipWith mk_bang_ty strict_marks arg_tys)

    	    | otherwise
	    = RecCon (zipWith mk_field strict_marks field_labels)

    mk_bang_ty NotMarkedStrict     ty = Unbanged (toHsType ty)
    mk_bang_ty (MarkedUnboxed _ _) ty = Unpacked (toHsType ty)
    mk_bang_ty MarkedStrict        ty = Banged   (toHsType ty)

    mk_field strict_mark field_label
	= ([toRdrName field_label], mk_bang_ty strict_mark (fieldLabelType field_label))

ifaceTyCon tycon
  = pprPanic "pprIfaceTyDecl" (ppr tycon)

ifaceClass clas
  = TyClD (ClassDecl (toHsContext sc_theta)
		     (toRdrName clas)
		     (toHsTyVars clas_tyvars)
		     (toHsFDs clas_fds)
		     (map toClassOpSig op_stuff)
		     EmptyMonoBinds NoClassPragmas
		     bogus bogus bogus [] noSrcLoc
    )
  where
     bogus = error "ifaceClass"
     (clas_tyvars, clas_fds, sc_theta, _, op_stuff) = classExtraBigSig clas

     toClassOpSig (sel_id, dm_id, explicit_dm)
	= ASSERT( sel_tyvars == clas_tyvars)
465
	  ClassOpSig (toRdrName sel_id) (Just (bogus, explicit_dm)) (toHsType op_ty) noSrcLoc
466
467
	where
	  (sel_tyvars, _, op_ty) = splitSigmaTy (idType sel_id)
468
469
\end{code}

470
471
472

%************************************************************************
%*				 					*
473
\subsection{Value bindings}
474
475
476
%*				 					*
%************************************************************************

477
\begin{code}
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
ifaceBinds :: IdSet		-- These Ids are needed already
	   -> [Id]		-- Ids used at code-gen time; they have better pragma info!
	   -> [CoreBind]	-- In dependency order, later depend on earlier
	   -> (Bag RdrNameHsDecl, IdSet)		-- Set of Ids actually spat out

ifaceBinds needed_ids final_ids binds
  = go needed_ids (reverse binds) emptyBag emptyVarSet 
		-- Reverse so that later things will 
		-- provoke earlier ones to be emitted
  where
    final_id_map  = listToUFM [(id,id) | id <- final_ids]
    get_idinfo id = case lookupUFM final_id_map id of
			Just id' -> idInfo id'
			Nothing  -> pprTrace "ifaceBinds not found:" (ppr id) $
				    idInfo id
493

494
495
496
497
498
	-- The 'needed' set contains the Ids that are needed by earlier
	-- interface file emissions.  If the Id isn't in this set, and isn't
	-- exported, there's no need to emit anything
    need_id needed_set id = id `elemVarSet` needed_set || isUserExportedId id 

499
500
501
502
503
504
505
    go needed [] decls emitted
	| not (isEmptyVarSet needed) = pprTrace "ifaceBinds: free vars:" 
					  (sep (map ppr (varSetElems needed)))
				       (decls, emitted)
	| otherwise 		     = (decls, emitted)

    go needed (NonRec id rhs : binds) decls emitted
506
507
508
509
510
511
512
513
514
515
516
517
	| need_id needed id
	= if omitIfaceSigForId id then
	    go (needed `delVarSet` id) binds decls (emitted `extendVarSet` id)
	  else
	    go ((needed `unionVarSet` extras) `delVarSet` id)
	       binds
	       (decl `consBag` decls)
	       (emitted `extendVarSet` id)
	| otherwise
	= go needed binds decls emitted
	where
	  (decl, extras) = ifaceId get_idinfo False id rhs
518
519
520

	-- Recursive groups are a bit more of a pain.  We may only need one to
	-- start with, but it may call out the next one, and so on.  So we
521
522
523
	-- have to look for a fixed point.  We don't want necessarily them all, 
	-- because without -O we may only need the first one (if we don't emit
	-- its unfolding)
524
525
526
527
528
529
530
531
532
533
534
    go needed (Rec pairs : binds) decls emitted
	= go needed' binds decls' emitted' 
	where
	  (new_decls, new_emitted, extras) = go_rec needed pairs
	  decls'   = new_decls `unionBags` decls
	  needed'  = (needed `unionVarSet` extras) `minusVarSet` mkVarSet (map fst pairs) 
	  emitted' = emitted `unionVarSet` new_emitted

    go_rec :: IdSet -> [(Id,CoreExpr)] -> (Bag RdrNameHsDecl, IdSet, IdSet)
    go_rec needed pairs
	| null decls = (emptyBag, emptyVarSet, emptyVarSet)
535
536
537
	| otherwise  = (more_decls   `unionBags`   listToBag decls, 
			more_emitted `unionVarSet` mkVarSet (map fst needed_prs),
			more_extras  `unionVarSet` extras)
538
	where
539
540
541
542
543
544
	  (needed_prs,leftover_prs) = partition is_needed pairs
	  (decls, extras_s)         = unzip [ifaceId get_idinfo True id rhs 
				            | (id,rhs) <- needed_prs, not (omitIfaceSigForId id)]
	  extras	            = unionVarSets extras_s
	  (more_decls, more_emitted, more_extras) = go_rec extras leftover_prs
	  is_needed (id,_) = need_id needed id
545
546
547
548
549
550
551
552
553
\end{code}


\begin{code}
ifaceId :: (Id -> IdInfo)	-- This function "knows" the extra info added
				-- by the STG passes.  Sigh
	-> Bool			-- True <=> recursive, so don't print unfolding
	-> Id
	-> CoreExpr		-- The Id's right hand side
554
	-> (RdrNameHsDecl, IdSet)	-- The emitted stuff, plus any *extra* needed Ids
555

556
557
ifaceId get_idinfo is_rec id rhs
  = (SigD (IfaceSig (toRdrName id) (toHsType id_type) hs_idinfo noSrcLoc),  new_needed_ids)
558
  where
559
    id_type     = idType id
560
561
    core_idinfo = idInfo id
    stg_idinfo  = get_idinfo id
562

563
564
565
    hs_idinfo | opt_OmitInterfacePragmas = []
 	      | otherwise		 = arity_hsinfo  ++ caf_hsinfo  ++ cpr_hsinfo ++ 
					   strict_hsinfo ++ wrkr_hsinfo ++ unfold_hsinfo
566
567

    ------------  Arity  --------------
568
569
    arity_info   = arityInfo stg_idinfo
    stg_arity	 = arityLowerBound arity_info
570
571
572
    arity_hsinfo = case arityInfo stg_idinfo of
			a@(ArityExactly n) -> [HsArity a]
			other		   -> []
573

574
    ------------ Caf Info --------------
575
576
577
    caf_hsinfo = case cafInfo stg_idinfo of
		   NoCafRefs -> [HsNoCafRefs]
		   otherwise -> []
578

579
    ------------ CPR Info --------------
580
581
582
    cpr_hsinfo = case cprInfo core_idinfo of
		   ReturnsCPR -> [HsCprInfo]
		   NoCPRInfo  -> []
583

584
    ------------  Strictness  --------------
585
    strict_info   = strictnessInfo core_idinfo
586
    bottoming_fn  = isBottomingStrictness strict_info
587
588
589
590
    strict_hsinfo = case strict_info of
			NoStrictnessInfo -> []
			info		 -> [HsStrictness info]

sof's avatar
sof committed
591

592
    ------------  Worker  --------------
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
	-- We only treat a function as having a worker if
	-- the exported arity (which is now the number of visible lambdas)
	-- is the same as the arity at the moment of the w/w split
	-- If so, we can safely omit the unfolding inside the wrapper, and
	-- instead re-generate it from the type/arity/strictness info
	-- But if the arity has changed, we just take the simple path and
	-- put the unfolding into the interface file, forgetting the fact
	-- that it's a wrapper.  
	--
	-- How can this happen?  Sometimes we get
	--	f = coerce t (\x y -> $wf x y)
	-- at the moment of w/w split; but the eta reducer turns it into
	--	f = coerce t $wf
	-- which is perfectly fine except that the exposed arity so far as
	-- the code generator is concerned (zero) differs from the arity
	-- when we did the split (2).  
	--
	-- All this arises because we use 'arity' to mean "exactly how many
	-- top level lambdas are there" in interface files; but during the
	-- compilation of this module it means "how many things can I apply
	-- this to".
    work_info           = workerInfo core_idinfo
    HasWorker work_id _ = work_info

    has_worker = case work_info of
		  HasWorker work_id wrap_arity 
		   | wrap_arity == stg_arity -> True
		   | otherwise		     -> pprTrace "ifaceId: arity change:" (ppr id) 
						False
							  
		  other			     -> False

    wrkr_hsinfo | has_worker = [HsWorker (toRdrName work_id)]
		| otherwise  = []
627

628
    ------------  Unfolding  --------------
629
    inline_pragma  = inlinePragInfo core_idinfo
630
    dont_inline	   = isNeverInlinePrag inline_pragma
631

632
633
    unfold_hsinfo | show_unfold = [HsUnfold inline_pragma (toUfExpr rhs)]
		  | otherwise   = []
634

635
636
637
    show_unfold = not has_worker	 &&	-- Not unnecessary
		  not bottoming_fn	 &&	-- Not necessary
		  not dont_inline	 &&
638
		  not loop_breaker	 &&
639
640
		  rhs_is_small		 &&	-- Small enough
		  okToUnfoldInHiFile rhs 	-- No casms etc
641

642
    rhs_is_small = couldBeSmallEnoughToInline opt_UF_HiFileThreshold rhs
643
644

    ------------  Specialisations --------------
645
    spec_info   = specInfo core_idinfo
646
    
647
648
649
    ------------  Occ info  --------------
    loop_breaker  = isLoopBreaker (occInfo core_idinfo)

650
    ------------  Extra free Ids  --------------
651
652
653
654
    new_needed_ids | opt_OmitInterfacePragmas = emptyVarSet
	           | otherwise		      = worker_ids	`unionVarSet`
						unfold_ids	`unionVarSet`
						spec_ids
655

656
    worker_ids | has_worker && interestingId work_id = unitVarSet work_id
657
658
			-- Conceivably, the worker might come from
			-- another module
659
	       | otherwise = emptyVarSet
660

661
    spec_ids = filterVarSet interestingId (rulesRhsFreeVars spec_info)
662
663

    unfold_ids | show_unfold = find_fvs rhs
664
	       | otherwise   = emptyVarSet
665

666
    find_fvs expr = exprSomeFreeVars interestingId expr
667

668
    
669
interestingId id = isId id && isLocallyDefined id && not (hasNoBinding id)
670
671
\end{code}