MkIface.lhs 23.6 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"

sof's avatar
sof committed
11
12
import IO		( Handle, hPutStr, openFile, 
			  hClose, hPutStrLn, IOMode(..) )
13
14

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

import TcInstUtil	( InstInfo(..) )

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

import PprType
60
import Rules		( pprProtoCoreRule, ProtoCoreRule(..) )
61

sof's avatar
sof committed
62
import Bag		( bagToList, isEmptyBag )
63
import Maybes		( catMaybes, maybeToBool )
64
65
import UniqFM		( lookupUFM, listToUFM )
import Util		( sortLt, mapAccumL )
66
import SrcLoc		( noSrcLoc )
67
import Bag
68
import Outputable
69
import ErrUtils		( dumpIfSet )
70
71

import Maybe 		( isNothing )
72
import List		( partition )
73
import Monad 		( when )
74
75
76
\end{code}


77
78
79
80
81
%************************************************************************
%*				 					*
\subsection{Write a new interface file}
%*				 					*
%************************************************************************
82

83
\begin{code}
84
85
86
writeIface this_mod old_iface new_iface
	   local_tycons local_classes inst_info
	   final_ids tidy_binds tidy_orphan_rules
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
  = 
    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
103

104
105
106
107
    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
108

109
	  Just final_iface ->
110

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

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


128
129
130
131
132
%************************************************************************
%*				 					*
\subsection{Checking if the new interface is up to date
%*				 					*
%************************************************************************
133
134

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

-- 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!
148
  = return (Just new_iface)
149
150
151

checkIface (Just iface) new_iface
  | no_output_change && no_usage_change
152
  = return Nothing
153
154

  | otherwise		-- Add updated version numbers
155
156
  = do { dumpIfSet opt_D_dump_hi_diffs "Interface file changes" pp_diffs ;
	 return (Just new_iface )}
157
	
158
  where
159
160
161
162
163
    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 }

164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
    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

188
    (no_decl_changed, pp_diffs, final_decls) = merge_decls True empty [] (pi_decls iface) (pi_decls new_iface)
189
190
191
192
193

	-- 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
194
195
196
197
    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)
198
	= case d_name `compare` nd_name of
199
200
201
202
		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
203
204
205
	where
 	  d_name  = hsDeclName d
 	  nd_name = hsDeclName nd
206
207
208
209
210

    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))
211
212
213
214
215
216
217
218
219
\end{code}



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

221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
\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)
247
248
\end{code}

249
250
251
252
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
253

254
\begin{code}
255
256
257
pprExport :: ExportItem -> SDoc
pprExport (mod, items)
 = hsep [ ptext SLIT("__export "), ppr mod, hsep (map upp_avail items) ] <> semi
sof's avatar
sof committed
258
  where
259
260
261
262
263
264
265
266
267
268
269
    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))
270
271
\end{code}

272

273
\begin{code}
274
275
276
277
278
279
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
280
  where
281
282
283
284
    pp_orphan | has_orphans = char '!'
	      | otherwise   = empty
    pp_boot   | is_boot     = char '@'
              | otherwise   = empty
285

286
	-- Importing the whole module is indicated by an empty list
287
288
289
290
291
    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}
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
319
320
321
322

\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)
    }
323
  where
324
325
326
     all_decls = cls_dcls ++ ty_dcls ++ bagToList val_dcls
     (inst_dcls, inst_ids) = ifaceInstances inst_info
     cls_dcls = map ifaceClass local_classes
327
  
328
329
330
331
332
333
334
335
336
337
338
     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]

339
340
341
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
342
\end{code}
343

344

345
346
%************************************************************************
%*				 					*
347
\subsection{Completion stuff}
348
349
%*				 					*
%************************************************************************
350

351
352
353
354
355
356
357
358
359
360
361
362
363
\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
364
365
366
367

			-- 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))
368
369
370
371
				-- 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}
372
373

\begin{code}			 
374
375
376
377
378
379
380
ifaceInstances :: Bag InstInfo -> ([RdrNameInstDecl], IdSet)
		   -- The IdSet is the needed dfuns

ifaceInstances inst_infos
  = (decls, needed_ids)
  where			
    decls       = map to_decl togo_insts
381
    togo_insts	= filter is_togo_inst (bagToList inst_infos)
382
383
    needed_ids  = mkVarSet [dfun_id | InstInfo _ _ _ _ dfun_id _ _ _ <- togo_insts]
    is_togo_inst (InstInfo _ _ _ _ dfun_id _ _ _) = isLocallyDefined dfun_id
384
385
				 
    -------			 
386
    to_decl (InstInfo clas tvs tys theta dfun_id _ _ _)
387
      = let			 
388
389
390
391
392
393
394
395
396
		-- 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.
397
398
	    forall_ty     = mkSigmaTy tvs (classesToPreds theta)
				      (deNoteType (mkDictTy clas tys))
399
	    tidy_ty = tidyTopType forall_ty
400
	in			 
401
	InstDecl (toHsType tidy_ty) EmptyMonoBinds [] (Just (toRdrName dfun_id)) noSrcLoc 
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
465
466
467
468
\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)
469
	  ClassOpSig (toRdrName sel_id) (Just (bogus, explicit_dm)) (toHsType op_ty) noSrcLoc
470
471
	where
	  (sel_tyvars, _, op_ty) = splitSigmaTy (idType sel_id)
472
473
\end{code}

474
475
476

%************************************************************************
%*				 					*
477
\subsection{Value bindings}
478
479
480
%*				 					*
%************************************************************************

481
\begin{code}
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
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
497

498
499
500
501
502
	-- 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 

503
504
505
506
507
508
509
    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
510
511
512
513
514
515
516
517
518
519
520
521
	| 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
522
523
524

	-- 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
525
526
527
	-- 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)
528
529
530
531
532
533
534
535
536
537
538
    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)
539
540
541
	| otherwise  = (more_decls   `unionBags`   listToBag decls, 
			more_emitted `unionVarSet` mkVarSet (map fst needed_prs),
			more_extras  `unionVarSet` extras)
542
	where
543
544
545
546
547
548
	  (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
549
550
551
552
553
554
555
556
557
\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
558
	-> (RdrNameHsDecl, IdSet)	-- The emitted stuff, plus any *extra* needed Ids
559

560
561
ifaceId get_idinfo is_rec id rhs
  = (SigD (IfaceSig (toRdrName id) (toHsType id_type) hs_idinfo noSrcLoc),  new_needed_ids)
562
  where
563
    id_type     = idType id
564
565
    core_idinfo = idInfo id
    stg_idinfo  = get_idinfo id
566

567
568
569
    hs_idinfo | opt_OmitInterfacePragmas = []
 	      | otherwise		 = arity_hsinfo  ++ caf_hsinfo  ++ cpr_hsinfo ++ 
					   strict_hsinfo ++ wrkr_hsinfo ++ unfold_hsinfo
570
571

    ------------  Arity  --------------
572
573
    arity_info   = arityInfo stg_idinfo
    stg_arity	 = arityLowerBound arity_info
574
575
576
    arity_hsinfo = case arityInfo stg_idinfo of
			a@(ArityExactly n) -> [HsArity a]
			other		   -> []
577

578
    ------------ Caf Info --------------
579
580
581
    caf_hsinfo = case cafInfo stg_idinfo of
		   NoCafRefs -> [HsNoCafRefs]
		   otherwise -> []
582

583
    ------------ CPR Info --------------
584
585
586
    cpr_hsinfo = case cprInfo core_idinfo of
		   ReturnsCPR -> [HsCprInfo]
		   NoCPRInfo  -> []
587

588
    ------------  Strictness  --------------
589
    strict_info   = strictnessInfo core_idinfo
590
    bottoming_fn  = isBottomingStrictness strict_info
591
592
593
594
    strict_hsinfo = case strict_info of
			NoStrictnessInfo -> []
			info		 -> [HsStrictness info]

sof's avatar
sof committed
595

596
    ------------  Worker  --------------
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
627
628
629
630
	-- 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  = []
631

632
    ------------  Unfolding  --------------
633
    inline_pragma  = inlinePragInfo core_idinfo
634
    dont_inline	   = isNeverInlinePrag inline_pragma
635

636
637
    unfold_hsinfo | show_unfold = [HsUnfold inline_pragma (toUfExpr rhs)]
		  | otherwise   = []
638

639
640
641
    show_unfold = not has_worker	 &&	-- Not unnecessary
		  not bottoming_fn	 &&	-- Not necessary
		  not dont_inline	 &&
642
		  not loop_breaker	 &&
643
644
		  rhs_is_small		 &&	-- Small enough
		  okToUnfoldInHiFile rhs 	-- No casms etc
645

646
    rhs_is_small = couldBeSmallEnoughToInline opt_UF_HiFileThreshold rhs
647
648

    ------------  Specialisations --------------
649
    spec_info   = specInfo core_idinfo
650
    
651
652
653
    ------------  Occ info  --------------
    loop_breaker  = isLoopBreaker (occInfo core_idinfo)

654
    ------------  Extra free Ids  --------------
655
656
657
658
    new_needed_ids | opt_OmitInterfacePragmas = emptyVarSet
	           | otherwise		      = worker_ids	`unionVarSet`
						unfold_ids	`unionVarSet`
						spec_ids
659

660
    worker_ids | has_worker && interestingId work_id = unitVarSet work_id
661
662
			-- Conceivably, the worker might come from
			-- another module
663
	       | otherwise = emptyVarSet
664

665
    spec_ids = filterVarSet interestingId (rulesRhsFreeVars spec_info)
666
667

    unfold_ids | show_unfold = find_fvs rhs
668
	       | otherwise   = emptyVarSet
669

670
    find_fvs expr = exprSomeFreeVars interestingId expr
671

672
673
674
    ------------ Sanity checking --------------
	-- The arity of a wrapper function should match its strictness,
	-- or else an importing module will get very confused indeed.
675
676
677
678
    arity_matches_strictness 
       = case work_info of
	     HasWorker _ wrap_arity -> wrap_arity == arityLowerBound arity_info
	     other		    -> True
679
    
680
interestingId id = isId id && isLocallyDefined id && not (hasNoBinding id)
681
682
\end{code}