MkIface.lhs 21.9 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,
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
70

import Maybe 		( isNothing )
71
72
73
\end{code}


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

80
\begin{code}
81
82
83
writeIface this_mod old_iface new_iface
	   local_tycons local_classes inst_info
	   final_ids tidy_binds tidy_orphan_rules
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
  = 
    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
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116

    case checkIface old_iface full_new_iface of {
	Nothing -> do { putStrLn "Interface file unchanged" ;
		        return () } ;	-- No need to update .hi file

	Just final_iface ->

    do  let mod_vers_unchanged = case old_iface of
				   Just iface -> pi_vers iface == pi_vers final_iface
				   Nothing -> False
     	if mod_vers_unchanged 
	   then putStrLn "Module version unchanged, but usages differ; hence need new hi file"
	   else return ()

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


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

\begin{code}
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
checkIface :: Maybe ParsedIface		-- The old interface, read from M.hi
	   -> ParsedIface		-- The new interface; but with all version numbers = 1
	   -> Maybe ParsedIface		-- Nothing => no change; no need to write new Iface
					-- Just pi => Here is the new interface to write
					-- 	      with correct version numbers

-- 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!
  = Just new_iface

checkIface (Just iface) new_iface
  | no_output_change && no_usage_change
  = Nothing

  | otherwise		-- Add updated version numbers
  = 
{-  pprTrace "checkIface" (
	vcat [ppr no_decl_changed <+> ppr no_export_change <+> ppr no_usage_change,
	      text "--------",
	      vcat (map ppr (pi_decls iface)),
	      text "--------",
	      vcat (map ppr (pi_decls new_iface))
	]) $
-}
    Just (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
    })
	
166
  where
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
207
208
209
210
211
212
213
214
215
216
217
    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

    (no_decl_changed, final_decls) = merge_decls True [] (pi_decls iface) (pi_decls new_iface)

	-- 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
    merge_decls ok_so_far acc []  []        = (ok_so_far, reverse acc)
    merge_decls ok_so_far acc old []        = (False, reverse acc)
    merge_decls ok_so_far acc [] (nvd:nvds) = merge_decls False (nvd:acc) [] nvds
    merge_decls ok_so_far acc (vd@(v,d):vds) (nvd@(_,nd):nvds)
	= case d_name `compare` nd_name of
		LT -> merge_decls False acc       vds      (nvd:nvds)
		GT -> merge_decls False (nvd:acc) (vd:vds) nvds
		EQ | d == nd   -> merge_decls ok_so_far (vd:acc) vds nvds
		   | otherwise -> merge_decls False	((bumpVersion v, nd):acc) vds nvds
	where
 	  d_name  = hsDeclName d
 	  nd_name = hsDeclName nd
\end{code}



%************************************************************************
%*				 					*
\subsection{Printing the interface}
%*				 					*
%************************************************************************
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
243
244
\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)
245
246
\end{code}

247
248
249
250
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
251

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

270

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

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

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

lt_inst_decl (InstDecl _ _ _ dfun_id1 _) (InstDecl _ _ _ dfun_id2 _)
   = dfun_id1 < dfun_id2
	-- The dfuns are assigned names df1, df2, etc, 
	-- in order of original textual
	-- occurrence, and this makes as good a sort order as any

lt_decl d1 d2 = hsDeclName d1 < hsDeclName d2
343
\end{code}
344

345

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

352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
\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
		     all (`elemVarSet` emitted) (varSetElems (ruleSomeLhsFreeVars interestingId rule))
				-- 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}
370
371

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

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

472
473
474

%************************************************************************
%*				 					*
475
\subsection{Value bindings}
476
477
478
%*				 					*
%************************************************************************

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

496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
    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
	= case ifaceId get_idinfo needed False id rhs of
		Nothing		      -> go needed binds decls emitted
		Just (decl, extras) -> let
			needed' = (needed `unionVarSet` extras) `delVarSet` id
			-- 'extras' can include the Id itself via a rule
			emitted' = emitted `extendVarSet` id
			in
			go needed' binds (decl `consBag` decls) emitted'

	-- 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
	-- have to look for a fixed point.
    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)
	| otherwise	= (more_decls `unionBags`   listToBag decls, 
			   more_emitted  `unionVarSet` mkVarSet emitted,
			   more_extras   `unionVarSet` extras)
	where
	  maybes	     = map do_one pairs
	  emitted	     = [id   | ((id,_), Just _)  <- pairs `zip` maybes]
	  reduced_pairs	     = [pair | (pair,   Nothing) <- pairs `zip` maybes]
	  (decls, extras_s)  = unzip (catMaybes maybes)
	  extras	     = unionVarSets extras_s
	  (more_decls, more_emitted, more_extras) = go_rec extras reduced_pairs

	  do_one (id,rhs) = ifaceId get_idinfo needed True id rhs
\end{code}


\begin{code}
ifaceId :: (Id -> IdInfo)	-- This function "knows" the extra info added
				-- by the STG passes.  Sigh

	-> IdSet		-- Set of 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
	-> Bool			-- True <=> recursive, so don't print unfolding
	-> Id
	-> CoreExpr		-- The Id's right hand side
	-> Maybe (RdrNameHsDecl, IdSet)	-- The emitted stuff, plus any *extra* needed Ids
552

553
ifaceId get_idinfo needed_ids is_rec id rhs
554
  | not (id `elemVarSet` needed_ids ||		-- Needed [no id in needed_ids has omitIfaceSigForId]
555
	(isUserExportedId id && not (omitIfaceSigForId id)))	-- or exported and not to be omitted
556
557
  = Nothing 		-- Well, that was easy!

558
ifaceId get_idinfo needed_ids is_rec id rhs
559
  = ASSERT2( arity_matches_strictness, ppr id )
560
561
    Just (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
574
575
    arity_info     = arityInfo stg_idinfo
    arity_hsinfo = case arityInfo stg_idinfo of
			a@(ArityExactly n) -> [HsArity a]
			other		   -> []
576

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

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

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

sof's avatar
sof committed
594

595
    ------------  Worker  --------------
596
    work_info     = workerInfo core_idinfo
597
    has_worker    = workerExists work_info
598
599
600
    wrkr_hsinfo   = case work_info of
			HasWorker work_id _ -> [HsWorker (toRdrName work_id)]
			other		    -> []
601

602
    ------------  Unfolding  --------------
603
    inline_pragma  = inlinePragInfo core_idinfo
604
    dont_inline	   = isNeverInlinePrag inline_pragma
605

606
607
    unfold_hsinfo | show_unfold = [HsUnfold inline_pragma (toUfExpr rhs)]
		  | otherwise   = []
608

609
610
611
    show_unfold = not has_worker	 &&	-- Not unnecessary
		  not bottoming_fn	 &&	-- Not necessary
		  not dont_inline	 &&
612
		  not loop_breaker	 &&
613
614
		  rhs_is_small		 &&	-- Small enough
		  okToUnfoldInHiFile rhs 	-- No casms etc
615

616
    rhs_is_small = couldBeSmallEnoughToInline opt_UF_HiFileThreshold rhs
617
618

    ------------  Specialisations --------------
619
    spec_info   = specInfo core_idinfo
620
    
621
622
623
    ------------  Occ info  --------------
    loop_breaker  = isLoopBreaker (occInfo core_idinfo)

624
    ------------  Extra free Ids  --------------
625
626
627
628
    new_needed_ids | opt_OmitInterfacePragmas = emptyVarSet
	           | otherwise		      = worker_ids	`unionVarSet`
						unfold_ids	`unionVarSet`
						spec_ids
629

630
631
    worker_ids = case work_info of
		   HasWorker work_id _ | interestingId work_id -> unitVarSet work_id
632
633
			-- Conceivably, the worker might come from
			-- another module
634
		   other -> emptyVarSet
635

636
    spec_ids = filterVarSet interestingId (rulesRhsFreeVars spec_info)
637
638

    unfold_ids | show_unfold = find_fvs rhs
639
	       | otherwise   = emptyVarSet
640

641
    find_fvs expr = exprSomeFreeVars interestingId expr
642

643
644
645
    ------------ Sanity checking --------------
	-- The arity of a wrapper function should match its strictness,
	-- or else an importing module will get very confused indeed.
646
647
648
649
    arity_matches_strictness 
       = case work_info of
	     HasWorker _ wrap_arity -> wrap_arity == arityLowerBound arity_info
	     other		    -> True
650
    
651
652
interestingId id = isId id && isLocallyDefined id &&
		   not (omitIfaceSigForId id)
653
654
\end{code}