IlxGen.lhs 109 KB
Newer Older
rrt's avatar
rrt committed
1
%
rrt's avatar
rrt committed
2
\section{Generate .NET extended IL}
rrt's avatar
rrt committed
3
4
5
6
7
8
9
10

\begin{code}
module IlxGen( ilxGen ) where

#include "HsVersions.h"

import Char	( ord, chr )
import StgSyn
11
import Id	( idType, idName, isDeadBinder, idArity )
rrt's avatar
rrt committed
12
13
import Var	( Var, Id, TyVar, isId, isTyVar, tyVarKind, tyVarName )
import VarEnv
rrt's avatar
rrt committed
14
import VarSet   ( isEmptyVarSet )
15
import TyCon	( TyCon,  tyConPrimRep, isUnboxedTupleTyCon, tyConDataCons, 
16
		  tyConTyVars, isDataTyCon, isAlgTyCon, tyConArity
17
18
		)
import Type	( liftedTypeKind, openTypeKind, unliftedTypeKind,
19
		  isUnLiftedType, isTyVarTy, mkTyVarTy, sourceTypeRep,
rrt's avatar
rrt committed
20
		  splitForAllTys, splitFunTys, applyTy, applyTys, eqKind, tyVarsOfTypes
21
22
		)
import TypeRep	( Type(..) )
rrt's avatar
rrt committed
23
import DataCon	( isUnboxedTupleCon, dataConTyCon, dataConRepType, dataConRepArgTys, DataCon(..) )
24
25
import Literal	( Literal(..) )
import PrelNames	-- Lots of keys
26
import PrimOp		( PrimOp(..) )
27
import ForeignCall	( CCallConv(..), ForeignCall(..), CCallSpec(..), CCallTarget(..), DNCallSpec(..) )
28
29
import TysWiredIn	( mkTupleTy, tupleCon )
import PrimRep		( PrimRep(..) )
30
import Name		( nameModule, nameOccName, isGlobalName, isLocalName, NamedThing(getName) )
31
import Subst   		( substTyWith )
32

33
34
import Module		( Module, PackageName, ModuleName, moduleName, 
                          modulePackage, preludePackage,
35
			  isHomeModule, isVanillaModule,
36
                          pprModuleName, mkHomeModule, mkModuleName
37
38
			)

rrt's avatar
rrt committed
39
import UniqFM
40
import BasicTypes	( Boxity(..) )
41
import CStrings		( CLabelString, pprCLabelString )
rrt's avatar
rrt committed
42
import Outputable
43
44
import Char		( ord )
import List		( partition, elem, insertBy,any  )
rrt's avatar
rrt committed
45
import UniqSet
46
import PprType		( pprType )	-- Only called in debug messages
47

48
import TysPrim  ( foreignObjPrimTyCon, weakPrimTyCon, byteArrayPrimTyCon, mutableByteArrayPrimTyCon )
49
50

-- opt_SimplDoEtaReduction is used to help with assembly naming conventions for different
rrt's avatar
rrt committed
51
-- versions of compiled Haskell code.  We add a ".O" to all assembly and module 
52
53
-- names when this is set (because that's clue that -O was set).  
-- One day this will be configured by the command line.
54
import CmdLineOpts	( opt_InPackage, opt_SimplDoEtaReduction )
rrt's avatar
rrt committed
55

sof's avatar
sof committed
56
57
import Util		( lengthIs, equalLength )

rrt's avatar
rrt committed
58
59
60
61
62
63
64
65
66
67
68
\end{code}



%************************************************************************
%*									*
\subsection{Main driver}
%*									*
%************************************************************************

\begin{code}
69
70
71
ilxGen :: Module -> [TyCon] -> [(StgBinding,[Id])] -> SDoc
	-- The TyCons should include those arising from classes
ilxGen mod tycons binds_w_srts
rrt's avatar
rrt committed
72
73
  =  vcat [ text ".module '" <> (ppr (moduleName mod)) <> hscOptionQual <> text "o'",
	    text ".assembly extern 'mscorlib' {}",
rrt's avatar
rrt committed
74
	    vcat (map (ilxImportPackage topenv) (uniqSetToList import_packages)),
rrt's avatar
rrt committed
75
76
            vcat (map (ilxImportModule topenv) (uniqSetToList import_modules)),
            vcat (map (ilxImportTyCon topenv) (uniqSetToList import_tycons)),
77
            vcat (map (ilxImportCCall topenv) (map snd (ufmToList import_ccalls))),
rrt's avatar
rrt committed
78
79
80
81
82
83
84
85
86
            vcat (map (ilxTyCon topenv) data_tycons),
            vcat (map (ilxBindClosures topenv) binds),
	    ilxTopBind mod topenv toppairs
	 ]
    where
      binds = map fst binds_w_srts
      toppairs = ilxPairs binds
      topenv = extendIlxEnvWithTops (emptyIlxEnv False mod) mod toppairs
 	-- Generate info from class decls as well
87
      (import_packages,import_modules,import_tycons,import_ccalls) = importsBinds topenv binds (importsPrelude emptyImpInfo)
88
      data_tycons = filter isDataTyCon tycons
rrt's avatar
rrt committed
89
90
91
92
93
94
95
96
97
98
\end{code}

%************************************************************************
%*									*
\subsection{Find Imports}
%*									*
%************************************************************************

\begin{code}

rrt's avatar
rrt committed
99
importsBinds :: IlxEnv -> [StgBinding] -> ImportsInfo -> ImportsInfo
100
importsBinds env binds = foldR (importsBind env) binds
rrt's avatar
rrt committed
101

102
103
importsNone :: ImportsInfo -> ImportsInfo
importsNone sofar = sofar
rrt's avatar
rrt committed
104

105
106
107
108
109
110
111
112
113
114
115
116
importsBind :: IlxEnv -> StgBinding -> ImportsInfo -> ImportsInfo
importsBind env (StgNonRec _ b rhs) = importsRhs env rhs.importsVar env b
importsBind env (StgRec _ pairs) = foldR (\(b,rhs) -> importsRhs env rhs . importsVar env b) pairs

importsRhs :: IlxEnv -> StgRhs -> ImportsInfo -> ImportsInfo
importsRhs env (StgRhsCon _ con args) = importsDataCon env con . importsStgArgs env args
importsRhs env (StgRhsClosure _ _ _ _ args body) = importsExpr env body. importsVars env args

importsExpr :: IlxEnv -> StgExpr -> ImportsInfo -> ImportsInfo
importsExpr env (StgLit _) = importsNone
importsExpr env (StgApp f args) = importsVar env f.importsStgArgs env args
importsExpr env (StgConApp con args) = importsDataCon env con.importsStgArgs env args
117
importsExpr env (StgOpApp (StgFCallOp (CCall (CCallSpec (StaticTarget c) cc _)) _) args rty)
118
119
120
121
  = addCCallInfo (c,cc, map stgArgType tm_args, rty) . importsStgArgs env args
  where 
    (ty_args,tm_args) = splitTyArgs1 args 

122
importsExpr env (StgOpApp _ args res_ty) = importsType env res_ty. importsStgArgs env args
123
124
125
126
127


importsExpr env (StgSCC _ expr) = importsExpr env expr
importsExpr env (StgCase scrut _ _ bndr _ alts)
  = importsExpr env scrut. imports_alts alts. importsVar env bndr
rrt's avatar
rrt committed
128
   where
129
    imports_alts (StgAlgAlts _ alg_alts deflt) 	-- The Maybe TyCon part is dealt with 
130
						-- by the case-binder's type
131
      = foldR imports_alg_alt alg_alts .  imports_deflt deflt
rrt's avatar
rrt committed
132
133
       where
        imports_alg_alt (con, bndrs, _, rhs)
134
	  = importsExpr env rhs . importsDataCon env con. importsVars env bndrs
rrt's avatar
rrt committed
135

136
137
    imports_alts (StgPrimAlts _ alg_alts deflt)
      = foldR imports_prim_alt alg_alts . imports_deflt deflt
rrt's avatar
rrt committed
138
       where
139
        imports_prim_alt (_, rhs) = importsExpr env rhs
140
    imports_deflt StgNoDefault = importsNone
141
    imports_deflt (StgBindDefault rhs) = importsExpr env rhs
rrt's avatar
rrt committed
142

143

144
145
146
importsExpr env (StgLetNoEscape _ _ bind body) = importsExpr env (StgLet bind body)
importsExpr env (StgLet bind body)
  = importsBind env bind .  importsExpr env body
rrt's avatar
rrt committed
147

148
149
importsApp env v args = importsVar env v.  importsStgArgs env args
importsStgArgs env args = foldR (importsStgArg env) args
rrt's avatar
rrt committed
150

151
152
153
154
importsStgArg :: IlxEnv -> StgArg -> ImportsInfo -> ImportsInfo
importsStgArg env (StgTypeArg ty) = importsType env ty
importsStgArg env (StgVarArg v) = importsVar env v
importsStgArg env _ = importsNone
rrt's avatar
rrt committed
155

156
157
importsVars env vs = foldR (importsVar env) vs
importsVar env v = importsName env (idName v). importsType env (idType v)
rrt's avatar
rrt committed
158

159
importsName env n
160
   | isLocalName n = importsNone
rrt's avatar
rrt committed
161
   | ilxEnvModule env == nameModule n = importsNone
162
   | isHomeModule (nameModule n) =  addModuleImpInfo (moduleName (nameModule n))
163
164
165
166
-- See HACK below
   | isVanillaModule (nameModule n)  && not inPrelude =  importsPrelude
   | isVanillaModule (nameModule n)  && inPrelude =   addModuleImpInfo (moduleName (nameModule n))
-- End HACK
167
168
   | otherwise = addPackageImpInfo (modulePackage (nameModule n))

rrt's avatar
rrt committed
169

rrt's avatar
rrt committed
170
171
172
173
importsPrelude | inPrelude = addModuleImpInfo (mkModuleName "PrelGHC")
	       | otherwise = addPackageImpInfo preludePackage


174
175
importsType :: IlxEnv -> Type -> ImportsInfo -> ImportsInfo
importsType env ty = importsType2 env (deepIlxRepType ty)
rrt's avatar
rrt committed
176

177
importsType2 :: IlxEnv -> Type -> ImportsInfo -> ImportsInfo
rrt's avatar
rrt committed
178
importsType2 env (AppTy f x) =  importsType2 env f . importsType2 env x
179
180
181
182
183
184
185
importsType2 env (TyVarTy _) = importsNone
importsType2 env (TyConApp tc args) =importsTyCon env tc . importsTypeArgs2 env args
importsType2 env (FunTy arg res) =  importsType env arg .  importsType2 env res
importsType2 env (ForAllTy tv body_ty) =  importsType2 env body_ty
importsType2 env (NoteTy _ ty) = importsType2 env ty
importsType2 _ _ = panic "IlxGen.lhs: importsType2 ty"
importsTypeArgs2 env tys = foldR (importsType2 env) tys
rrt's avatar
rrt committed
186

187
importsDataCon env dcon = importsTyCon env (dataConTyCon dcon)
188

189
importsTyCon env tc | (not (isDataTyCon tc) || 
rrt's avatar
rrt committed
190
                   isLocalName (getName tc) || 
191
                   ilxEnvModule env == nameModule (getName tc)) = importsNone
rrt's avatar
rrt committed
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
importsTyCon env tc | otherwise = importsName env (getName tc) . addTyConImpInfo tc .
				    foldR (importsTyConDataCon env) (tyConDataCons tc)


importsTyConDataCon :: IlxEnv -> DataCon -> ImportsInfo -> ImportsInfo
importsTyConDataCon env dcon = foldR (importsTyConDataConType env) (filter (not . isVoidIlxRepType) (dataConRepArgTys dcon))

importsTyConDataConType :: IlxEnv -> Type -> ImportsInfo -> ImportsInfo
importsTyConDataConType env ty = importsTyConDataConType2 env (deepIlxRepType ty)

importsTyConDataConType2 :: IlxEnv -> Type -> ImportsInfo -> ImportsInfo
importsTyConDataConType2 env (AppTy f x) =  importsTyConDataConType2 env f . importsTyConDataConType2 env x
importsTyConDataConType2 env (TyVarTy _) = importsNone
importsTyConDataConType2 env (TyConApp tc args) = importsTyConDataConTypeTyCon env tc . importsTyConDataConTypeArgs2 env args
importsTyConDataConType2 env (FunTy arg res) = importsTyConDataConType env arg .  importsTyConDataConType2 env res
importsTyConDataConType2 env (ForAllTy tv body_ty) = importsTyConDataConType2 env body_ty
importsTyConDataConType2 env (NoteTy _ ty) = importsTyConDataConType2 env ty
importsTyConDataConType2 _ _ = panic "IlxGen.lhs: importsTyConDataConType2 ty"
importsTyConDataConTypeArgs2 env tys = foldR (importsTyConDataConType2 env) tys

importsTyConDataConTypeTyCon env tc | (not (isDataTyCon tc) || 
                   isLocalName (getName tc) || 
                   ilxEnvModule env == nameModule (getName tc)) = importsNone
importsTyConDataConTypeTyCon env tc | otherwise = importsName env (getName tc)
rrt's avatar
rrt committed
216
217


218
type StaticCCallInfo = (CLabelString,CCallConv,[Type],Type)
219
220
type ImportsInfo = (UniqSet PackageName, UniqSet ModuleName, UniqSet TyCon, UniqFM StaticCCallInfo)
   -- (Packages, Modules, Datatypes, Imported CCalls)
rrt's avatar
rrt committed
221
222

emptyImpInfo :: ImportsInfo
223
224
225
226
227
emptyImpInfo = (emptyUniqSet, emptyUniqSet, emptyUniqSet, emptyUFM)
addPackageImpInfo p (w,x,y,z) = (addOneToUniqSet w p, x, y,z)
addModuleImpInfo m (w,x,y,z) = (w, addOneToUniqSet x m, y,z)
addTyConImpInfo tc (w,x,y,z) = (w, x, addOneToUniqSet y tc,z)
addCCallInfo info@(nm,a,b,c) (w,x,y,z) = (w, x, y,addToUFM z nm info)
rrt's avatar
rrt committed
228
229

ilxImportTyCon :: IlxEnv -> TyCon -> SDoc
230
231
ilxImportTyCon env tycon | isDataTyCon tycon = ilxTyConDef True env tycon
ilxImportTyCon _ _ | otherwise =  empty
rrt's avatar
rrt committed
232
233

ilxImportPackage :: IlxEnv -> PackageName -> SDoc
rrt's avatar
rrt committed
234
ilxImportPackage _ p = text ".assembly extern" <+> singleQuotes (ppr p <> hscOptionQual) <+> text "{ }"
rrt's avatar
rrt committed
235
236

ilxImportModule :: IlxEnv -> ModuleName -> SDoc
rrt's avatar
rrt committed
237
ilxImportModule _ m = text ".module extern" <+> singleQuotes (ppr m <> hscOptionQual <> text "o")
238
239
240
241
242

-- Emit a P/Invoke declaration for the imported C function
-- TODO: emit the right DLL name
ilxImportCCall :: IlxEnv -> StaticCCallInfo -> SDoc
ilxImportCCall env (c,cc,args,ret) = 
243
    text ".method static assembly pinvokeimpl" <+> 
244
245
    parens (doubleQuotes (text "HSstd_cbits.dll") <+> text "cdecl") <+> retdoc <+> singleQuotes (pprCLabelString c) <+> 
    pprCValArgTys ilxTypeL env (map deepIlxRepType (filter (not. isVoidIlxRepType) args)) <+> 
rrt's avatar
rrt committed
246
    text "unmanaged preservesig { }"
247
248
249
250
  where 
    retdoc = 
          if isVoidIlxRepType ret then text "void" 
          else ilxTypeR env (deepIlxRepType ret)
rrt's avatar
rrt committed
251
252
253
254
255
256
257
258
259
260
261
262
263
264


\end{code}

%************************************************************************
%*									*
\subsection{Type declarations}
%*									*
%************************************************************************

\begin{code}


ilxTyCon :: IlxEnv -> TyCon -> SDoc
265
ilxTyCon env tycon =  ilxTyConDef False env tycon
rrt's avatar
rrt committed
266
267

-- filter to get only dataTyCons?
268
ilxTyConDef importing env tycon = 
rrt's avatar
rrt committed
269
	vcat [empty $$ line,
270
	      text ".classunion" <+> (if importing then text "import" else empty) <+> tycon_ref <+> tyvars_text <+> super_text   <+> alts_text]
rrt's avatar
rrt committed
271
   where
272
273
     tycon_ref =  nameReference env (getName tycon)  <> (ppr tycon)
     super_text = if importing then empty else text "extends thunk" <> angleBrackets (text "class" <+> tycon_ref)
rrt's avatar
rrt committed
274
     tyvars = tyConTyVars tycon
275
     (ilx_tvs, _) = categorizeTyVars tyvars
rrt's avatar
rrt committed
276
277
278
279
280
281
282
     alts_env = extendIlxEnvWithFormalTyVars env ilx_tvs 
     tyvars_text = pprTyVarBinders alts_env ilx_tvs 
     alts = vcat (map (pprIlxDataCon alts_env) (tyConDataCons tycon))
     alts_text = nest 2 (braces alts)

pprIlxDataCon env dcon =
        text ".alternative" <+> pprId dcon <+> 
283
        parens (pprSepWithCommas (ilxTypeL env) (map deepIlxRepType (filter (not. isVoidIlxRepType) (dataConRepArgTys dcon))))
rrt's avatar
rrt committed
284
285
286
287
288
289
290
291
292
293
294
\end{code}


%************************************************************************
%*									*
\subsection{Getting the .closures and literals out}			*
%************************************************************************

\begin{code}

ilxBindClosures :: IlxEnv -> StgBinding -> SDoc
295
296
ilxBindClosures env (StgNonRec _ b rhs) = ilxRhsClosures env (b,rhs)
ilxBindClosures env (StgRec _ pairs)  
rrt's avatar
rrt committed
297
298
299
300
301
  = vcat (map (ilxRhsClosures new_env) pairs)
  where
     new_env = extendIlxEnvWithBinds env pairs

---------------
302
ilxRhsClosures _ (_, StgRhsCon _ _ _)
rrt's avatar
rrt committed
303
304
  = empty

305
ilxRhsClosures env (bndr, StgRhsClosure _ _ fvs upd args rhs)
rrt's avatar
rrt committed
306
307
308
  = vcat [ilxExprClosures next_env rhs,

	 empty $$ line,
309
	 kind_text <+> singleQuotes cloname <+>  free_vs_text,
rrt's avatar
rrt committed
310
311
312
313
314
315
316
317
318
319
320
321
	 nest 2 (braces (
	    nest 2 (vcat [empty,
                          vcat [text ".apply" <+> closure_sig_text,
                                body_text
                          ],
                          empty
                    ])
                ))
    ]
  where
    kind_of_thing = case upd of
			  Updatable -> ASSERT( null args ) ".thunk"
322
			  otherwise -> ".closure"
rrt's avatar
rrt committed
323
324
325
326
327
328
329
330
    kind_text = text kind_of_thing 
		
    cloname = ilxEnvQualifyByModule env (ppr bndr)
    next_env = ilxPlaceStgRhsClosure env bndr 
    (free_vs_text,env_with_fvs) = pprFreeBinders next_env fvs


    closure_sig_text =     
331
332
      vcat [ text "()",
             (case args of 
333
334
               []        -> empty
               otherwise -> args_text),
rrt's avatar
rrt committed
335
336
337
338
339
340
341
             text "-->" <+>  rty_text]

    (args_text,env_with_args) = pprArgBinders env_with_fvs args

        -- Find the type returned, from the no. of args and the type of "bndr"
    rty_text = 
      case retType env_with_fvs (idIlxRepType bndr) args of
342
343
344
345
       Just (env,ty) -> 
          if isVoidIlxRepType ty  then  (text "void")
          else ilxTypeR env ty 
       Nothing -> trace "WARNING!  IlxGen.trace could not find return type - see generated ILX for context where this occurs." (text "// Could not find return type:" <+> ilxTypeR env_with_fvs (idIlxRepType bndr)<+> text ", non representation: " <+> ilxTypeR env_with_fvs (idType bndr))
rrt's avatar
rrt committed
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376

    -- strip off leading ForAll and Fun type constructions
    -- up to the given number of arguments, extending the environment as
    -- we go.  
    retType env ty [] = Just (env, ty)
    retType env (ForAllTy tv ty) (arg:args) = retType (extendIlxEnvWithTyArgs env [tv]) ty args
    retType env (FunTy l r) (arg:args) = retType env r args
    retType _ _ _  = Nothing

	-- Code for the local variables
    locals = ilxExprLocals env_with_args rhs

    env_with_locals = extendIlxEnvWithLocals env_with_args locals

	-- Code for the body of the main apply method
    body_code = vcat [empty,
                      pprIlxLocals env_with_args locals,
		      ilxExpr (IlxEEnv env_with_locals (mkUniqSet (filter (not.isTyVar) args))) rhs Return,
                      empty
	        ]

    body_text = nest 2 (braces (text ".maxstack 100" <+> nest 2 body_code))


pprIlxLocals env [] = empty
pprIlxLocals env vs 
   = text ".locals" <+> parens (pprSepWithCommas (pprIlxLocal env) (filter nonVoidLocal vs))
  where
    nonVoidLocal (LocalId v,_) = not (isVoidIlxRepId v)
    nonVoidLocal _ = True

377
378
pprIlxLocal env (LocalId v,_) = ilxTypeL env (idIlxRepType v) <+> pprId v
pprIlxLocal env (LocalSDoc (ty,doc,pin),_) = ilxTypeL env (deepIlxRepType ty) <+> (if pin then text "pinned" else empty) <+> doc
rrt's avatar
rrt committed
379
380
381
382
383


pprFreeBinders env fvs 
    = (ilx_tvs_text <+> vs_text, env2)
    where   
384
       (free_ilx_tvs, _,free_vs) = categorizeVars fvs
rrt's avatar
rrt committed
385
386
387
388
389
       real_free_vs = filter (not . isVoidIlxRepId) free_vs
        -- ignore the higher order type parameters for the moment
       env1 = extendIlxEnvWithFreeTyVars env free_ilx_tvs 
       ilx_tvs_text = pprTyVarBinders env1 free_ilx_tvs
       vs_text = parens (pprSepWithCommas ppr_id real_free_vs)
390
       ppr_id v = ilxTypeL env1 (idIlxRepType v) <+> pprId v 
rrt's avatar
rrt committed
391
392
       env2 = extendIlxEnvWithFreeVars env1 real_free_vs 

393
pprIdBinder env v = parens (ilxTypeL env (idIlxRepType v) <+> pprId v)
rrt's avatar
rrt committed
394
395
396
397
398
399
400
401
402
403
404
405

	-- Declarations for the arguments of the main apply method
pprArgBinders env [] = (empty,env)
pprArgBinders env (arg:args)
    = (arg_text <+> rest_text, res_env)
   where 
     (arg_text,env') = pprArgBinder env arg
     (rest_text,res_env) = pprArgBinders env' args 

-- We could probably omit some void argument binders, but
-- don't...
pprArgBinder env arg 
406
  | isVoidIlxRepId arg = (text "()", extendIlxEnvWithArgs env [arg])
rrt's avatar
rrt committed
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
  | otherwise 
      = if isTyVar arg then 
         let env' = extendIlxEnvWithTyArgs env [arg] in 
         (pprTyVarBinder env' arg, env')
      else (pprIdBinder env arg,extendIlxEnvWithArgs env [arg])

--------------
-- Compute local variables used by generated method.
-- The names of some generated locals are recorded as SDocs.

data LocalSpec = LocalId Id | LocalSDoc (Type, SDoc, Bool)  -- flag is for pinning

ilxExprLocals :: IlxEnv -> StgExpr -> [(LocalSpec,Maybe (IlxEnv,StgRhs))]
ilxExprLocals env (StgLet bind body) 		  = ilxBindLocals env bind ++ ilxExprLocals env body
ilxExprLocals env (StgLetNoEscape _ _ bind body)  = ilxBindLocals env bind ++ ilxExprLocals env body  -- TO DO????
ilxExprLocals env (StgCase scrut _ _ bndr _ alts) 
     = ilxExprLocals (ilxPlaceStgCaseScrut env) scrut ++ 
       (if isDeadBinder bndr then [] else [(LocalId bndr,Nothing)]) ++ 
       ilxAltsLocals env alts
426
ilxExprLocals env (StgOpApp (StgFCallOp fcall _) args _) 
rrt's avatar
rrt committed
427
428
429
430
431
     = concat (ilxMapPlaceArgs 0 ilxCCallArgLocals env args)
ilxExprLocals _ _  = []

-- Generate locals to use for pinning arguments as we cross the boundary
-- to C.
432
ilxCCallArgLocals env (StgVarArg v) | pinCCallArg v = 
rrt's avatar
rrt committed
433
434
435
   [(LocalSDoc (idType v, ilxEnvQualifyByExact env (ppr v) <> text "pin", True), Nothing)]
ilxCCallArgLocals _ _ | otherwise = []

436
437
ilxBindLocals env (StgNonRec _ b rhs) = [(LocalId b,Just (env, rhs))]
ilxBindLocals env (StgRec _ pairs)    = map (\(x,y) -> (LocalId x,Just (env, y))) pairs
rrt's avatar
rrt committed
438
439
440
441

ilxAltsLocals env (StgAlgAlts  _ alts deflt) = ilxDefltLocals env deflt ++ concat (ilxMapPlaceAlts ilxAlgAltLocals env alts)
ilxAltsLocals env (StgPrimAlts _ alts deflt) = ilxDefltLocals env deflt ++ concat (ilxMapPlaceAlts ilxPrimAltLocals env alts)

442
443
ilxAlgAltLocals env (_, bndrs, _, rhs) = map (\x -> (LocalId x,Nothing)) (filter (\v -> isId v && not (isDeadBinder v)) bndrs) ++ ilxExprLocals env rhs
ilxPrimAltLocals env (_, rhs)          = ilxExprLocals env rhs
rrt's avatar
rrt committed
444

445
ilxDefltLocals _ StgNoDefault 	= []
rrt's avatar
rrt committed
446
447
448
449
450
451
452
453
ilxDefltLocals env (StgBindDefault rhs) = ilxExprLocals (ilxPlaceStgBindDefault env) rhs

--------------
ilxExprClosures :: IlxEnv -> StgExpr -> SDoc
ilxExprClosures env (StgApp _ args)
  = vcat (ilxMapPlaceArgs 0 (ilxArgClosures) env args)  -- get strings
ilxExprClosures env (StgConApp _ args)
  = vcat (ilxMapPlaceArgs 0 (ilxArgClosures) env args) -- get strings
454
ilxExprClosures env (StgOpApp _ args _)
rrt's avatar
rrt committed
455
456
457
458
459
460
461
462
463
  = vcat (ilxMapPlaceArgs 0 (ilxArgClosures) env args) -- get strings
ilxExprClosures env (StgLet bind body)
  = ilxBindClosures env bind $$ ilxExprClosures (extendIlxEnvWithBinds env (ilxPairs1 bind)) body
ilxExprClosures env (StgLetNoEscape _ _ bind body)  -- TO DO????
  = ilxBindClosures env bind $$ ilxExprClosures (extendIlxEnvWithBinds env (ilxPairs1 bind)) body
ilxExprClosures env (StgCase scrut _ _ _ _ alts)
  = ilxExprClosures (ilxPlaceStgCaseScrut env) scrut $$ ilxAltsClosures env alts 
ilxExprClosures env (StgLit lit) 
  = ilxGenLit env lit 
464
ilxExprClosures _ _ 
rrt's avatar
rrt committed
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
  = empty

ilxAltsClosures env (StgAlgAlts _ alts deflt)
  = vcat [ilxExprClosures (ilxPlaceAlt env i) rhs | (i,(_, _, _, rhs))  <- [1..] `zip` alts]
    $$ 
    ilxDefltClosures env deflt

ilxAltsClosures env (StgPrimAlts _ alts deflt)
  = vcat [ilxExprClosures (ilxPlaceAlt env i) rhs | (i,(_, rhs)) <- [1..] `zip` alts]
    $$ 
    vcat [ ilxGenLit (ilxPlacePrimAltLit env i) lit | (i,(lit,_)) <- [1..] `zip` alts]
    $$ 
    ilxDefltClosures  env deflt

ilxDefltClosures env (StgBindDefault rhs) = ilxExprClosures (ilxPlaceStgBindDefault env) rhs
480
ilxDefltClosures _ StgNoDefault	  = empty
rrt's avatar
rrt committed
481
482
483
484
485
486
487

ilxArgClosures env (StgLitArg lit) = ilxGenLit env lit 
ilxArgClosures _ _ = empty



ilxGenLit env (MachStr fs) 
488
  = vcat [text ".field static assembly char "  <+> singleQuotes nm <+> text "at" <+> nm <> text "L",
rrt's avatar
rrt committed
489
490
491
492
493
494
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
          text ".data" <+> nm <> text "L" <+> text "= char *("  <> pprFSInILStyle fs  <> text ")"
         ]
 where
   nm = ilxEnvQualifyByExact env (text "string")

ilxGenLit  _ _ = empty

\end{code}


%************************************************************************
%*									*
\subsection{Generating code}
%*									*
%************************************************************************


\begin{code}

-- Environment when generating expressions
data IlxEEnv = IlxEEnv IlxEnv (UniqSet Id)

data Sequel = Return | Jump IlxLabel

ilxSequel Return     = text "ret"
ilxSequel (Jump lbl) = text "br" <+> pprIlxLabel lbl

isReturn Return = True
isReturn (Jump _) = False


ilxExpr :: IlxEEnv -> StgExpr 
	-> Sequel 	-- What to do at the end
	-> SDoc

524
ilxExpr (IlxEEnv env _) (StgApp fun args) sequel
rrt's avatar
rrt committed
525
526
527
  = ilxFunApp env fun args (isReturn sequel) $$ ilxSequel sequel

-- ilxExpr eenv (StgLit lit) sequel
528
ilxExpr (IlxEEnv env _) (StgLit lit) sequel
rrt's avatar
rrt committed
529
530
531
  = pushLit env lit $$ ilxSequel sequel

-- ilxExpr eenv (StgConApp data_con args) sequel
532
ilxExpr (IlxEEnv env _) (StgConApp data_con args) sequel
rrt's avatar
rrt committed
533
534
535
  = text " /* ilxExpr:StgConApp */ " <+>  ilxConApp env data_con args $$ ilxSequel sequel

-- ilxExpr eenv (StgPrimApp primop args _) sequel
536
ilxExpr (IlxEEnv env _) (StgOpApp (StgFCallOp fcall _) args ret_ty) sequel
537
538
539
540
  = ilxFCall env fcall args ret_ty $$ ilxSequel sequel

ilxExpr (IlxEEnv env _) (StgOpApp (StgPrimOp primop) args ret_ty) sequel
  = ilxPrimOpTable primop args env $$ ilxSequel sequel
rrt's avatar
rrt committed
541
542
543
544

--BEGIN TEMPORARY
-- The following are versions of a peephole optimizations for "let t = \[] t2[fvs] in t"
-- I think would be subsumed by a general treatmenet of let-no-rec bindings??
545
ilxExpr eenv@(IlxEEnv env _) (StgLet (StgNonRec _ bndr (StgRhsClosure _ _ _ _ [] rhs)) (StgApp fun [])) sequel 
rrt's avatar
rrt committed
546
547
              | (bndr == fun && null (ilxExprLocals env rhs)) -- TO DO???
  = ilxExpr eenv rhs sequel
548
ilxExpr eenv@(IlxEEnv env _) (StgLetNoEscape _ _ (StgNonRec _ bndr (StgRhsClosure _ _ _ _ [] rhs)) (StgApp fun [])) sequel 
rrt's avatar
rrt committed
549
550
551
552
553
554
555
556
557
558
559
560
              | (bndr == fun && null (ilxExprLocals env rhs)) -- TO DO???
  = ilxExpr eenv rhs sequel
--END TEMPORARY

ilxExpr eenv (StgLet bind body) sequel
  = ilxBind eenv bind $$ ilxExpr eenv body sequel


ilxExpr eenv (StgLetNoEscape _ _ bind body) sequel -- TO DO???
  = ilxBind eenv bind $$ ilxExpr eenv body sequel

-- StgCase: Special case 1 to avoid spurious branch.
561
ilxExpr eenv@(IlxEEnv env live) (StgCase (StgApp fun args) live_in_case _live_in_alts bndr _ alts) sequel
rrt's avatar
rrt committed
562
563
  = vcat [ilxWipe env (uniqSetToList (live `minusUniqSet` live_in_case)),
	  ilxFunApp (ilxPlaceStgCaseScrut env) fun args False,
564
565
          --ilxWipe env (uniqSetToList (live_in_case `minusUniqSet` _live_in_alts)),
	  --ilxAlts (IlxEEnv env _live_in_alts) bndr alts sequel
rrt's avatar
rrt committed
566
567
568
569
	  ilxAlts (IlxEEnv env live_in_case) bndr alts sequel
    ]

-- StgCase: Special case 2 to avoid spurious branch.
570
ilxExpr eenv@(IlxEEnv env live) (StgCase (StgOpApp (StgPrimOp primop) args ret_ty) live_in_case _live_in_alts bndr _ alts) sequel
rrt's avatar
rrt committed
571
  = vcat [ilxWipe env (uniqSetToList (live `minusUniqSet` live_in_case)),
572
	  ilxPrimOpTable primop args (ilxPlaceStgCaseScrut env),
573
574
          --ilxWipe env (uniqSetToList (live_in_case `minusUniqSet` _live_in_alts)),
	  --ilxAlts (IlxEEnv env _live_in_alts) bndr alts sequel
rrt's avatar
rrt committed
575
576
577
578
	  ilxAlts (IlxEEnv env live_in_case) bndr alts sequel
    ]

-- StgCase: Normal case.
579
ilxExpr eenv@(IlxEEnv env live) (StgCase scrut live_in_case _live_in_alts bndr _ alts) sequel
rrt's avatar
rrt committed
580
581
582
  = vcat [ilxWipe env (uniqSetToList (live `minusUniqSet` live_in_case)),
	  ilxExpr (IlxEEnv (ilxPlaceStgCaseScrut env) live_in_case) scrut (Jump join_lbl),
	  ilxLabel join_lbl,
583
584
          --ilxWipe env (uniqSetToList (live_in_case `minusUniqSet` _live_in_alts)),
	  --ilxAlts (IlxEEnv env _live_in_alts) bndr alts sequel
rrt's avatar
rrt committed
585
586
587
588
589
	  ilxAlts (IlxEEnv env live_in_case) bndr alts sequel
    ]
  where
    join_lbl = mkJoinLabel bndr

590
591
592
593
ilxExpr _ _ _ 
  = panic "ilxExpr:  Patterns not matched:(IlxEEnv _ _) (StgSCC _ _) _ (IlxEEnv _ _) (StgLam _ _ _) _"


rrt's avatar
rrt committed
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
-- Wipe out locals and arguments that are no longer in use, to
-- prevent space leaks. If the VM is implemented 100% correctly then
-- this should probably not be needed, as the live variable analysis
-- in the JIT would tell the GC that these locals and arguments are
-- no longer live.  However I'm putting it in here so we can
-- check out if it helps.
--
-- Also, in any case this doesn't capture everything we need.  e.g.
-- when making a call:
--     case f x of ...
-- where x is not used in the alternatives, then the variable x
-- is no longer live from the point it is transferred to the call
-- onwards.  We should expunge "live_in_case - live_in_alts" right
-- before making the call, not after returning from the call....
--
-- Strictly speaking we also don't need to do this for primitive
-- values such as integers and addresses, i.e. things not
-- mapped down to GC'able objects.
ilxWipe env ids 
   = vcat (map (ilxWipeOne env) (filter (not.isVoidIlxRepId) ids))

ilxWipeOne env id
   = case lookupIlxVarEnv env id of
rrt's avatar
rrt committed
617
	  Just Local  -> text "ldloca " <+> pprId id <+> text "initobj.any" <+> (ilxTypeL env (idIlxRepType id))
618
	  Just Arg   -> text "deadarg " <+> pprId id <+> text "," <+> (ilxTypeL env (idIlxRepType id))
rrt's avatar
rrt committed
619
620
621
622
623
624
625
626
	  Just (CloVar _)  -> ilxComment (text "not yet wiping closure variable" <+> pprId id )
	  _ -> ilxComment (text "cannot wipe non-local/non-argument" <+> pprId id )
  where 
      

----------------------

ilxAlts :: IlxEEnv -> Id -> StgCaseAlts -> Sequel -> SDoc
627
ilxAlts (IlxEEnv env live) bndr alts sequel
rrt's avatar
rrt committed
628
629
630
631
632
633
	-- At the join label, the result is on top
	-- of the stack
  = vcat [store_in_bndr,
	  do_case_analysis alts
    ]
  where
634
635
    scrut_rep_ty = deepIlxRepType (idType bndr)

rrt's avatar
rrt committed
636
637
638
639
640
641
642
643
    store_in_bndr | isDeadBinder bndr = empty
                  | isVoidIlxRepId bndr 
                        = ilxComment (text "ignoring store of zero-rep value to be analyzed")
		  | otherwise	      = text "dup" $$ (text "stloc" <+> pprId bndr)

    do_case_analysis (StgAlgAlts _ []    deflt)
	= do_deflt deflt

644
645
    do_case_analysis (StgAlgAlts _ args deflt) 
        = do_alg_alts ([1..] `zip` args) deflt
rrt's avatar
rrt committed
646

647
    do_case_analysis (StgPrimAlts _ alts deflt)
rrt's avatar
rrt committed
648
649
	= do_prim_alts ([1..] `zip` alts) $$ do_deflt deflt

650
    do_alg_alts [(i, alt@(data_con,bndrs,used_flags, rhs))] StgNoDefault | isUnboxedTupleCon data_con
rrt's avatar
rrt committed
651
652
653
654
655
656
      -- Collapse the analysis of unboxed tuples where 
      -- some or all elements are zero-sized
      --
      -- TO DO: add bndrs to set of live variables
          = case bndrs' of
                  [h] -> bind_collapse bndrs used_flags <+> do_rhs_no_pop alt_env rhs
657
                  _ -> bind_components alt_env dcon' bndrs 0 used_flags <+> do_rhs alt_env rhs
rrt's avatar
rrt committed
658
659
660
661
           where 
            bndrs' = filter (not. isVoidIlxRepId) bndrs
            -- Replacement unboxed tuple type constructor, used if any of the
            -- arguments have zero-size and more than one remains.
662
            dcon'  = tupleCon Unboxed (length bndrs')
rrt's avatar
rrt committed
663
664
665
666
667
668
669
670
671
672
673

            alt_env = IlxEEnv (ilxPlaceAlt env i) live
            --alt_env = IlxEEnv (ilxPlaceAlt env i) 

            bind_collapse [] _ = panic "bind_collapse: unary element not found"
            bind_collapse (h:t) (is_used:used_flags) 
                | isVoidIlxRepId h = ilxComment (text "zero-rep binding eliminated") <+> (bind_collapse t used_flags)
	        | not is_used = ilxComment (text "not used") <+> text "pop"
                | otherwise = text "stloc" <+> pprId h


674
    do_alg_alts [(i, alt@(data_con,bndrs,used_flags, rhs))] StgNoDefault 
675
            = vcat [text "castdata" <+> sep [ilxTypeR env scrut_rep_ty <> comma,
rrt's avatar
rrt committed
676
		  			     ilxConRef env data_con],
677
 		do_alg_alt (IlxEEnv (ilxPlaceAlt env i) live) alt
rrt's avatar
rrt committed
678
679
	      ]

680
    do_alg_alts alts deflt
681
	= vcat [text "datacase" <+> sep [ilxTypeR env scrut_rep_ty,text ",",
rrt's avatar
rrt committed
682
683
					 pprSepWithCommas pp_case labels_w_alts],
		do_deflt deflt,
684
		vcat (map do_labelled_alg_alt labels_w_alts)
rrt's avatar
rrt committed
685
686
687
688
689
690
691
692
693
694
695
696
697
	  ]
	where
	  pp_case (i, (lbl, (data_con, _, _, _))) = parens (ilxConRef env data_con <> comma <> pprIlxLabel lbl)
	  labels_w_alts = [(i,(mkAltLabel bndr i, alt)) | (i, alt) <- alts]

    do_prim_alts [] = empty
    do_prim_alts ((i, (lit,alt)) : alts) 
	= vcat [text "dup", pushLit (ilxPlacePrimAltLit env i) lit, text "bne.un" <+> pprIlxLabel lbl, 
		do_rhs (IlxEEnv (ilxPlaceAlt env i) live) alt, 
		ilxLabel lbl, do_prim_alts alts]
	where
	  lbl = mkAltLabel bndr i

698
699
    do_labelled_alg_alt (i,(lbl, alt)) 
        = ilxLabel lbl $$ do_alg_alt (IlxEEnv (ilxPlaceAlt env i) live) alt
rrt's avatar
rrt committed
700

701
702
    do_alg_alt alt_eenv (data_con, bndrs, used_flags, rhs) 
      = vcat [bind_components alt_eenv data_con bndrs 0 used_flags,
rrt's avatar
rrt committed
703
704
705
	      do_rhs alt_eenv rhs
	     ]

706
707
    bind_components alt_eenv data_con [] n _ = empty
    bind_components alt_eenv data_con (h:t) n (is_used:used_flags) 
rrt's avatar
rrt committed
708
709
710
       | isVoidIlxRepId h 
             -- don't increase the count in this case
             = ilxComment (text "zero-rep binding eliminated") 
711
               <+> bind_components alt_eenv data_con t n used_flags
rrt's avatar
rrt committed
712
       | otherwise 
713
714
             = bind_component alt_eenv data_con h is_used n 
               <+> bind_components alt_eenv data_con t (n + 1) used_flags
rrt's avatar
rrt committed
715

716
    bind_component alt_eenv@(IlxEEnv alt_env _) data_con bndr is_used reduced_fld_no 
rrt's avatar
rrt committed
717
718
719
720
721
	| not is_used 
            = ilxComment (text "not used")
        | isVoidIlxRepId bndr 
            = ilxComment (text "ignoring bind of zero-rep variable")
	| otherwise   = vcat [text "dup",
722
			      ld_data alt_env data_con reduced_fld_no bndr,
rrt's avatar
rrt committed
723
724
725
726
727
728
729
730
731
732
733
			      text "stloc" <+> pprId bndr]

    do_deflt (StgBindDefault rhs) = do_rhs (IlxEEnv (ilxPlaceStgBindDefault env) live) rhs
    do_deflt StgNoDefault 	  = empty

    do_rhs alt_eenv rhs  
        | isVoidIlxRepId bndr = do_rhs_no_pop alt_eenv rhs     -- void on the stack, nothing to pop
        | otherwise = text "pop" $$ do_rhs_no_pop alt_eenv rhs  -- drop the value

    do_rhs_no_pop alt_env rhs = ilxExpr alt_env rhs sequel

734
    ld_data alt_env data_con reduced_fld_no bndr
rrt's avatar
rrt committed
735
      | isUnboxedTupleCon data_con
736
      = text "ldfld" <+> sep [text "!" <> integer reduced_fld_no,
737
			      ilxTypeR alt_env scrut_rep_ty <> text "::fld" <> integer reduced_fld_no]
rrt's avatar
rrt committed
738
      | otherwise 
739
      = text "lddata" <+> sep [ilxTypeR alt_env scrut_rep_ty <> comma, 
740
741
		               ilxConRef env data_con <> comma,
			       integer reduced_fld_no]
rrt's avatar
rrt committed
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760


-------------------------

ilxBestTermArity = 3
ilxBestTypeArity = 7


-- Constants of unlifted types are represented as
-- applications to no arguments.
ilxFunApp env fun [] _ | isUnLiftedType (idType fun)
  = pushId env fun

ilxFunApp env fun args tail_call 
  =	-- For example:
        --	ldloc f		function of type forall a. a->a
	--	ldloc x		arg of type Int
	--	.tail callfunc <Int32> (!0) --> !0
	--
761
762
763
764
765
766
767
768
769
    vcat [pushId env fun,ilxFunAppAfterPush env fun args tail_call]

ilxFunAppAfterPush env fun args tail_call 
  =	-- For example:
        --	ldloc f		function of type forall a. a->a
	--	ldloc x		arg of type Int
	--	.tail callfunc <Int32> (!0) --> !0
	--
    vcat [ilxFunAppArgs env 0 (idIlxRepType fun) args tail_call known_clo]
rrt's avatar
rrt committed
770
  where
771
    known_clo :: KnownClosure
rrt's avatar
rrt committed
772
773
    known_clo =
      case lookupIlxBindEnv env fun of
774
	  Just (_, StgRhsClosure  _ _ _ Updatable _ _)   -> Nothing 
775
	  Just (place, StgRhsClosure  _ _ fvs _ args _)  -> Just (place,fun,args,fvs)
776
	  _ -> Nothing -- trace (show fun ++ " --> " ++ show (idArity fun))
rrt's avatar
rrt committed
777

778
type KnownClosure = Maybe (  IlxEnv	-- Of the binding site of the function
779
780
781
782
783
			   , Id		-- The function
			   , [Var]	-- Binders
			   , [Var])	-- Free vars of the closure

-- Push as many arguments as ILX allows us to in one go, and call the function
rrt's avatar
rrt committed
784
-- Recurse until we're done.
785
786
787
788
789
790
791
792
793
794
-- The function is already on the stack
ilxFunAppArgs :: IlxEnv
	      -> Int		-- Number of args already pushed (zero is a special case;
				--	otherwise used only for place generation)
	      -> Type		-- Type of the function
	      -> [StgArg]	-- The arguments
	      -> Bool		-- True <=> tail call please
	      -> KnownClosure	-- Information about the function we're calling
	      -> SDoc

rrt's avatar
rrt committed
795
796
ilxFunAppArgs env num_sofar funty args tail_call known_clo
 =   vcat [vcat (ilxMapPlaceArgs num_sofar pushArgWithVoids env now_args),
797
798
	   call_instr <+> (if num_sofar == 0 then text "() /* first step in every Haskell app. is to a thunk */ " else empty)
                     <+> now_args_text
rrt's avatar
rrt committed
799
                     <+> text "-->" 
800
                     <+> later_ty_text,
rrt's avatar
rrt committed
801
802
803
           later
          ]
  where
804
805
806
807
    now_args_text = 
      case now_arg_tys of
        [] -> empty
        _ -> hsep (map (pprIlxArgInfo env_after_now_tyvs) now_arg_tys)
rrt's avatar
rrt committed
808

809
810
811
812
    later_ty_text
        | isVoidIlxRepType later_ty = text "void"
        | otherwise = ilxTypeR env_after_now_tyvs later_ty

rrt's avatar
rrt committed
813
814
815
    (now_args,now_arg_tys,env_after_now_tyvs,later_args,later_ty) = 
	case args of
          (StgTypeArg v:rest) -> get_type_args ilxBestTypeArity args env funty
816
          _ -> get_term_args 0 ilxBestTermArity args env funty
rrt's avatar
rrt committed
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842

     -- Only apply up to maxArity real (non-type) arguments
     -- at a time.  ILX should, in principle, allow us to apply
     -- arbitrary numbers, but you will get more succinct 
     -- (and perhaps more efficient) IL code
     -- if you apply in clumps according to its maxArity setting.
     -- This is because it has to unwind the stack and store it away
     -- in local variables to do the partial applications.
     --
     -- Similarly, ILX only allows one type application at a time, at
     -- least until we implement unwinding the stack for this case.
     --
     -- NB: In the future we may have to be more careful 
     -- all the way through 
     -- this file to bind type variables as we move through
     -- type abstractions and "forall" types.  This would apply
     -- especially if the type variables were ever bound by expressions
     -- involving the type variables.  

    -- This part strips off at most "max" term applications or one type application
    get_type_args 0 args env funty = ([],[],env,args,funty)
    get_type_args max args env (NoteTy _ ty) = 
          trace "IlxGen Internal Error: non representation type passed to get_args" (get_type_args max args env ty)
    get_type_args max ((arg@(StgTypeArg v)):rest) env (ForAllTy tv rem_funty) 
        = if isIlxTyVar tv then 
            let env2 = extendIlxEnvWithFormalTyVars env [tv] in 
843
            let rest_ty = deepIlxRepType (substTyWith [tv] [v] rem_funty) in 
rrt's avatar
rrt committed
844
845
846
847
848
849
850
851
            let (now,now_tys,env3,later,later_ty) = get_type_args (max - 1) rest env rest_ty in 
            let arg_ty = mkTyVarTy tv in 
            (arg:now,(arg,arg_ty):now_tys,env2, later, later_ty)
          else 
             get_type_args max rest env rem_funty  -- ? subst??
    get_type_args _ (StgTypeArg _:_) _ _ = trace "IlxGen Internal Error: get_type_args could not get ForAllTy for corresponding arg" ([],[],env,[],funty)
    get_type_args _ args env funty = ([],[],env,args,funty)

852
853
854
855
856
857
858
859
    get_term_args n max args env (NoteTy _ ty)
       -- Skip NoteTy types 
       = trace "IlxGen Internal Error: non representation type passed to get_term_args" (get_term_args n max args env ty)
    get_term_args n 0 args env funty
       -- Stop if we've hit the maximum number of ILX arguments to apply n one hit.
       = ([],[],env,args,funty)
    get_term_args n max args env funty
      | (case known_clo of
sof's avatar
sof committed
860
           Just (_,_,needed,_) -> needed `lengthIs` n
861
862
863
864
865
866
867
868
869
870
871
872
           Nothing -> False)
       -- Stop if we have the optimal number for a direct call
       = ([],[],env,args,funty)
    get_term_args _ _ (args@(StgTypeArg _:_)) env funty 
       -- Stop if we hit a type arg.
       = ([],[],env,args,funty)
    get_term_args n max (h:t) env (FunTy dom ran)
       -- Take an argument.
       = let (now,now_tys,env2,later,later_ty) = get_term_args (n+1) (max - 1) t env ran in 
         (h:now, (h,dom):now_tys,env2,later,later_ty)
    get_term_args _ max (h:t) env funty = trace "IlxGen Internal Error: get_term_args could not get FunTy or ForAllTy for corresponding arg" ([],[],env,[],funty)
    get_term_args _ max args env funty = ([],[],env,args,funty)
rrt's avatar
rrt committed
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901

    -- Are there any remaining arguments?
    done  = case later_args of
          [] -> True
          _ -> False

    -- If so, generate the subsequent calls.
    later = if done then text "// done"  
            else ilxFunAppArgs env (num_sofar + length now_args) later_ty later_args tail_call Nothing

    -- Work out whether to issue a direct call a known closure (callclo) or
    -- an indirect call (callfunc).  Basically, see if the identifier has
    -- been let-bound, and then check we are applying exactly the right 
    -- number of arguments.  Also check that it's not a thunk (actually, this
    -- is done up above).
    -- 
    -- The nasty "all" check makes sure that 
    -- the set of type variables in scope at the callsite is a superset 
    -- of the set of type variables needed for the direct call.  This is
    -- is needed because not all of the type variables captured by a 
    -- let-bound binding will get propogated down to the callsite, and 
    -- the ILX system of polymorphism demands that the free type variables
    -- get reapplied when we issue the direct "callclo".  The
    -- type variables are in reality also "bound up" in the closure that is
    -- passed as the first argument, so when we do an indirect call
    -- to that closure we're fine, which is why we don't need them in 
    -- the "callfunc" case.
    basic_call_instr =
      case known_clo of
sof's avatar
sof committed
902
        Just (known_env,fun,needed,fvs) | (equalLength needed now_args) && 
903
                                          all (\x -> elemIlxTyEnv x env) free_ilx_tvs -> 
rrt's avatar
rrt committed
904
           vcat [text "callclo class",
905
906
                 nameReference env (idName fun) <+> singleQuotes (ilxEnvQualifyByModule env (ppr fun)),
                 pprTypeArgs ilxTypeR env (map mkTyVarTy free_ilx_tvs)]
rrt's avatar
rrt committed
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
           <> text ","
          where 
           (free_ilx_tvs, free_non_ilx_tvs,free_vs) = categorizeVars fvs
        otherwise -> text "callfunc"
    call_instr =
           if (tail_call && done) then text "tail." <+> basic_call_instr
	   else basic_call_instr


--------------------------
-- Print the arg info at the call site
-- For type args we are, at the moment, required to
-- give both the actual and the formal (bound).  The formal
-- bound is always System.Object at the moment (bounds are
-- not properly implemented in ILXASM in any case, and nor do
-- we plan on making use og them) For
-- non-type args the actuals are on the stack, and we just give the
-- formal type.
pprIlxArgInfo env (StgTypeArg  arg,ty) =  
926
    angleBrackets (ilxTypeR env (deepIlxRepType arg) <+> ilxComment (text "actual for tyvar")) <+> text "<class [mscorlib] System.Object>" 
rrt's avatar
rrt committed
927
pprIlxArgInfo env (_,ty) =  
928
    parens (ilxTypeL env ty)
rrt's avatar
rrt committed
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953


----------------------------
-- Code for a binding
ilxBind :: IlxEEnv -> StgBinding -> SDoc
ilxBind eenv@(IlxEEnv env _) bind = 
    vcat [vcat (map (ilxRhs env rec) pairs), 
          vcat (map (ilxFixupRec env rec) pairs)]
       where 
         rec = ilxRecIds1 bind
         pairs = ilxPairs1 bind


----------------------------
-- Allocate a closure or constructor.  Fix up recursive definitions.
ilxRhs :: IlxEnv -> [Id] -> (Id, StgRhs) -> SDoc

ilxRhs env rec (bndr, _) | isVoidIlxRepId bndr  
  = empty

ilxRhs env rec (bndr, StgRhsCon _ con args)
  = vcat [text " /* ilxRhs:StgRhsCon */ " <+> ilxConApp env con args,
	   text "stloc" <+> pprId bndr
          ]

954
ilxRhs env rec (bndr, StgRhsClosure _ _ fvs upd args rhs)
rrt's avatar
rrt committed
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
  = 	-- Assume .closure v<any A>(int64,!A) { 
	--		.apply <any B> (int32) (B) { ... }
	--	   }
	-- Then
        --    let v = \B (x:int32) (y:B). ... 
        -- becomes:
        --    newclo v<int32>(int64,!0)
	--    stloc v
    vcat [vcat (map pushFv free_vs),
          (if null free_non_ilx_tvs then empty else (ilxComment (text "ignored some higher order type arguments in application - code will be non-verifiable"))),
	  text "newclo" <+> clotext,
	  text "stloc" <+> pprId bndr
    ]
  where
    pushFv id = if elem id rec then text "ldnull" else pushId env id
    (free_ilx_tvs, free_non_ilx_tvs,free_vs) = categorizeVars fvs
rrt's avatar
rrt committed
971
    clotext = pprIlxNamedTyConApp env (ilxEnvQualifyByModule env (ppr bndr)) (map mkTyVarTy free_ilx_tvs)
rrt's avatar
rrt committed
972
973
974
975
976
977

ilxFixupRec env rec (bndr, _) | isVoidIlxRepId bndr = ilxComment (text "no recursive fixup for void-rep-id")

ilxFixupRec env rec (bndr, StgRhsCon _ con args)
  = text "// no recursive fixup"

978
ilxFixupRec env rec (bndr, StgRhsClosure _ _ fvs upd args rhs)
rrt's avatar
rrt committed
979
980
981
982
983
984
985
986
     = vcat [vcat (map fixFv rec)]
  where
    fixFv recid = if elem recid fvs then 
                    vcat [pushId env bndr,
                          pushId env recid,
                          text "stclofld" <+> clotext <> text "," <+> pprId recid] 
                else text "//no fixup needed for" <+> pprId recid
    (free_ilx_tvs, free_non_ilx_tvs,free_vs) = categorizeVars fvs
rrt's avatar
rrt committed
987
    clotext = pprIlxNamedTyConApp env (ilxEnvQualifyByModule env (ppr bndr)) (map mkTyVarTy free_ilx_tvs)
rrt's avatar
rrt committed
988
989
990
991
992
993
994



---------------------------------------------
-- Code for a top-level binding in a module
ilxPairs binds = concat (map ilxPairs1 binds)

995
996
ilxPairs1 (StgNonRec _ bndr rhs) = [(bndr,rhs)]
ilxPairs1 (StgRec _ pairs)       = pairs
rrt's avatar
rrt committed
997

998
999
ilxRecIds1 (StgNonRec _ bndr rhs) = []
ilxRecIds1 (StgRec _ pairs)       = map fst pairs
rrt's avatar
rrt committed
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026

---------------------------------------------
-- Code for a top-level binding in a module
-- TODO: fix up recursions amongst CAF's
-- e.g. 
--    x = S x
-- for infinity...
-- 
-- For the moment I've put in a completely spurious "reverse"...
--
-- Consider: make fixing up of CAF's part of ILX?  i.e.
-- put static, constant, allocated datastructures into ILX. 

stableSortBy :: (a -> a -> Ordering) -> [a] -> [a]
stableSortBy f (h:t) = insertBy f h (stableSortBy f t)
stableSortBy f [] = []

usedBy :: (Id,StgRhs) -> (Id,StgRhs) -> Ordering
usedBy (m,_) (_,StgRhsCon _ data_con args) | any (isArg m) args = LT
usedBy (m,_) (n,_) | m == n = EQ
usedBy (m,_) (_,_) = GT

isArg m  (StgVarArg n) = (n == m)
isArg m _ = False


ilxTopBind :: Module -> IlxEnv -> [(Id,StgRhs)] -> SDoc
1027
--ilxTopBind mod env (StgNonRec _ bndr rhs) = 
rrt's avatar
rrt committed
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
--ilxTopRhs env (bndr,rhs)
ilxTopBind mod env pairs       = 
   vcat [text ".class" <+> pprId mod,
         nest 2 (braces (nest 2 (vcat [empty,cctor, flds, empty])))]
     where
       cctor = vcat [text ".method static rtspecialname specialname void .cctor()",
                     nest 2 (braces 
                      (nest 2 (vcat [text ".maxstack 100",
			             text "ldstr \"LOG: initializing module" <+> pprId mod <+> text "\" call void ['mscorlib']System.Console::WriteLine(class [mscorlib]System.String)",
                                     vcat (map (ilxTopRhs mod env) (stableSortBy usedBy pairs)), 
			             text "ldstr \"LOG: initialized module" <+> pprId mod <+> text "\" call void ['mscorlib']System.Console::WriteLine(class [mscorlib]System.String)",
                                     text "ret",
                                     empty])))]
       flds =   vcat (map (ilxTopRhsStorage mod env) pairs)

--ilxTopRhs mod env (bndr, _) | isVoidIlxRepId bndr 
--  = empty

1046
ilxTopRhs mod env (bndr, StgRhsClosure _ _ fvs upd args rhs)
rrt's avatar
rrt committed
1047
1048
  = vcat [vcat (map (pushId env) free_vs),
         (if null free_non_ilx_tvs then empty else (ilxComment (text "ignored some higher order type arguments in application - code will be non verifiable...."))),
rrt's avatar
rrt committed
1049
	  text "newclo" <+> pprIlxNamedTyConApp env (ilxEnvQualifyByModule env (ppr bndr)) (map mkTyVarTy free_ilx_tvs),
rrt's avatar
rrt committed
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
	  text "stsfld"  <+> pprFieldRef env (mod,bndTy,bndr)
    ]
  where
    (free_ilx_tvs, free_non_ilx_tvs,free_vs) = categorizeVars fvs
    bndTy = idIlxRepType bndr

ilxTopRhs mod env (bndr, StgRhsCon _ data_con args)
  = vcat [ text " /* ilxTopRhs: StgRhsCon */ " <+> ilxConApp env data_con args, 
	   text "stsfld" <+> pprFieldRef env (mod,bndTy,bndr)
    ]
  where
    bndTy = idIlxRepType bndr

pprFieldRef env (mod,ty,id) 
1064
  =  ilxTypeL env ty <+> moduleReference env mod <+> pprId mod <> text "::" <> pprId id
rrt's avatar
rrt committed
1065

1066
ilxTopRhsStorage mod env (bndr, StgRhsClosure _ _ _ _ _ _) 
1067
  =   text ".field public static " <+> ilxTypeL env bndTy <+> pprId bndr
rrt's avatar
rrt committed
1068
1069
1070
  where
    bndTy = idIlxRepType bndr
ilxTopRhsStorage mod env (bndr, StgRhsCon _ _ _) 
1071
  =   text ".field public static " <+> ilxTypeL env bndTy <+> pprId bndr
rrt's avatar
rrt committed
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
  where
    bndTy = idIlxRepType bndr

--------------------------------------
-- Push an argument
pushArgWithVoids =  pushArg_aux True
pushArg = pushArg_aux False

pushArg_aux voids env (StgTypeArg ty) = empty
pushArg_aux voids env (StgVarArg var) = pushId_aux voids env var
pushArg_aux voids env (StgLitArg lit) = pushLit env lit


mapi f l = mapi_aux f l 0

mapi_aux f [] n = []
mapi_aux f (h:t) n = f n h : mapi_aux f t (n+1)

--------------------------------------
-- Push an Id
pushId = pushId_aux False

pushId_aux :: Bool -> IlxEnv -> Id -> SDoc
pushId_aux voids _ id | isVoidIlxRepId id =
1096
   /* if voids then  text "ldunit" else */ ilxComment (text "pushId: void rep skipped")
rrt's avatar
rrt committed
1097
1098
1099
1100
1101
1102
1103
pushId_aux _ env var 
  = case lookupIlxVarEnv env var of
	  Just Arg    -> text "ldarg"    <+> pprId var
	  Just (CloVar n) -> text "ldenv" <+> int n
	  Just Local  -> text "ldloc"    <+> pprId var
	  Just (Top m)  -> 
             vcat [ilxComment (text "pushId (Top) " <+> pprId m), 
1104
                   text "ldsfld" <+> ilxTypeL env (idIlxRepType var)
rrt's avatar
rrt committed
1105
1106
1107
1108
                      <+> moduleReference env m <+> pprId (moduleName m) <> text "::" <> pprId var]

	  Nothing ->  
             vcat [ilxComment (text "pushId (import) " <+> pprIlxTopVar env var), 
1109
                   text "ldsfld" <+> ilxTypeL env (idIlxRepType var) 
rrt's avatar
rrt committed
1110
1111
1112
1113
                    <+> pprIlxTopVar env var]

--------------------------------------
-- Push a literal
1114
pushLit env (MachChar c)   = text "ldc.i4" <+> int c
rrt's avatar
rrt committed
1115
1116
1117
1118
1119
1120
1121
1122
pushLit env (MachStr s)    = text "ldsflda char "  <+> ilxEnvQualifyByExact env (text "string") -- pprFSInILStyle s 
pushLit env (MachInt i)    = text "ldc.i4" <+> integer i
pushLit env (MachInt64 i)  = text "ldc.i8" <+> integer i
pushLit env (MachWord w)   = text "ldc.i4" <+> integer w <+> text "conv.u4"
pushLit env (MachWord64 w) = text "ldc.i8" <+> integer w <+> text "conv.u8"
pushLit env (MachFloat f)  = text "ldc.r4" <+> rational f
pushLit env (MachDouble f) = text "ldc.r8" <+> rational f
pushLit env (MachLitLit _ _) = trace "WARNING: Cannot compile MachLitLit to ILX in IlxGen.lhs" (text "// MachLitLit!!!  Not valid in ILX!!")
1123
pushLit env (MachAddr w) = text "ldc.i4" <+> integer w <+> text "conv.i"
rrt's avatar
rrt committed
1124
pushLit env (MachLabel l) = trace "WARNING: Cannot compile MachLabel to ILX in IlxGen.lhs" (text "// MachLabel!!!  Not valid in ILX!!")
rrt's avatar
rrt committed
1125
1126

pprIlxTopVar env v
1127
  | isGlobalName n = (nameReference env n) <> pprId (nameModule n) <> text "::" <> singleQuotes (ppr (nameModule n) <> text "_" <> ppr (nameOccName n))
rrt's avatar
rrt committed
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
  | otherwise	   = pprId (nameOccName n)
  where
    n = idName v

\end{code}


%************************************************************************
%*									*
\subsection{Printing types}
%*									*
%************************************************************************


\begin{code}

isVoidIlxRepType (NoteTy   _ ty) = isVoidIlxRepType ty
isVoidIlxRepType (TyConApp tc _) | (tyConPrimRep tc == VoidRep) = True
isVoidIlxRepType (TyConApp tc tys) 
1147
  = isUnboxedTupleTyCon tc && null (filter (not. isVoidIlxRepType) tys)
rrt's avatar
rrt committed
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
isVoidIlxRepType _ = False

isVoidIlxRepId id = isVoidIlxRepType (idType id)



-- Get rid of all NoteTy and NewTy artifacts
deepIlxRepType :: Type -> Type
deepIlxRepType (FunTy l r)
  = FunTy (deepIlxRepType l) (deepIlxRepType r)

1159
deepIlxRepType ty@(TyConApp tc tys) 
1160
  =        -- collapse UnboxedTupleTyCon down when it contains VoidRep types.
1161
	   -- e.g. 	(# State#, Int#, Int# #)  ===>   (# Int#, Int# #)
rrt's avatar
rrt committed
1162
1163
1164
1165
            if isUnboxedTupleTyCon tc then 
               let tys' = map deepIlxRepType (filter (not. isVoidIlxRepType) tys) in 
               case tys' of
                  [h] -> h
1166
                  _ -> mkTupleTy Unboxed (length tys') tys'
rrt's avatar
rrt committed
1167
1168
            else 
              TyConApp tc (map deepIlxRepType tys)
1169
deepIlxRepType (AppTy f x)     = AppTy (deepIlxRepType f) (deepIlxRepType x)
rrt's avatar
rrt committed
1170
1171
deepIlxRepType (ForAllTy b ty) = ForAllTy b (deepIlxRepType ty)
deepIlxRepType (NoteTy   _ ty) = deepIlxRepType ty
1172
deepIlxRepType (SourceTy p)    = deepIlxRepType (sourceTypeRep p)
rrt's avatar
rrt committed
1173
1174
1175
1176
1177
1178
1179
deepIlxRepType ty@(TyVarTy tv) = ty

idIlxRepType id = deepIlxRepType (idType id)

--------------------------
-- Some primitive type constructors are not thunkable.
-- Everything else needs to be marked thunkable.
1180
ilxTypeL :: IlxEnv -> Type -> SDoc
rrt's avatar
rrt committed
1181

1182
1183
ilxTypeL env ty | isUnLiftedType ty ||  isVoidIlxRepType ty = ilxTypeR env ty
ilxTypeL env ty = text "thunk" <> angleBrackets (ilxTypeR env ty)
rrt's avatar
rrt committed
1184

1185

rrt's avatar
rrt committed
1186
1187
1188
1189
--------------------------
-- Print non-thunkable version of type.
--

1190
1191
1192
ilxTypeR :: IlxEnv -> Type -> SDoc
ilxTypeR env ty | isVoidIlxRepType ty = text "/* unit skipped */"
ilxTypeR env ty@(AppTy f _) | isTyVarTy f    = ilxComment (text "type app:" <+> pprType ty) <+> (text "class [mscorlib]System.Object")
rrt's avatar
rrt committed
1193
ilxTypeR env ty@(AppTy f x)     = trace "ilxTypeR: should I be beta reducing types?!" (ilxComment (text "ilxTypeR: should I be beta reducing types?!") <+> ilxTypeR env (applyTy f x))
1194
ilxTypeR env (TyVarTy tv)       = ilxTyVar env tv
rrt's avatar
rrt committed
1195
1196
1197
1198
1199
1200
1201

-- The following is a special rule for types constructed out of 
-- higher kinds, e.g. Monad f or Functor f.  
--
-- The code below is not as general as it should be, but as I
-- have no idea if this approach will even work, I'm going to
-- just try it out on some simple cases arising from the prelude.
1202
1203
1204
1205
1206
ilxTypeR env ty@(TyConApp tc (h:t)) | isAlgTyCon tc && null (tyConTyVars tc)
   = ilxComment (text "what on earth? 2") <+> (ilxTypeR env (TyConApp tc t))
ilxTypeR env ty@(TyConApp tc (h:t)) | isAlgTyCon tc && not (isIlxTyVar (hd (tyConTyVars tc)))
   = ilxTypeR env (TyConApp tc t)
ilxTypeR env (TyConApp tc args) = ilxTyConApp env tc args
rrt's avatar
rrt committed
1207
1208
1209
1210

  -- nb. the only legitimate place for VoidIlxRepTypes to occur in normalized IlxRepTypes 
  -- is on the left of an arrow
  --  We could probably eliminate all but a final occurrence of these.
1211
1212
1213
1214
ilxTypeR env (FunTy arg res)| isVoidIlxRepType res 
    = pprIlxFunTy (ilxTypeL env arg) (text "void")
ilxTypeR env (FunTy arg res)
    = pprIlxFunTy (ilxTypeL env arg) (ilxTypeR env res)
rrt's avatar
rrt committed
1215

1216
1217
ilxTypeR env ty@(ForAllTy tv body_ty) | isIlxTyVar tv
  = parens (text "forall" <+> pprTyVarBinders env' [tv] <+> nest 2 (ilxTypeR env' body_ty))
rrt's avatar
rrt committed
1218
1219
1220
    where
       env' = extendIlxEnvWithFormalTyVars env [tv]

1221
ilxTypeR env ty@(ForAllTy tv body_ty) | otherwise
rrt's avatar
rrt committed
1222
  = ilxComment (text "higher order type var " <+> pprId tv) <+>
1223
    pprIlxFunTy (text "class [mscorlib]System.Object") (ilxTypeR env body_ty)
rrt's avatar
rrt committed
1224

1225
1226
1227
1228
ilxTypeR env (NoteTy _ ty)       
   = trace "WARNING! non-representation type given to ilxTypeR: see generated ILX for context where this occurs"
     (vcat [text "/* WARNING! non-representation type given to ilxTypeR! */",
           ilxTypeR env ty ])
rrt's avatar
rrt committed
1229
1230
1231

pprIlxFunTy dom ran = parens (hsep [text "func",parens dom,text "-->", ran])

rrt's avatar
rrt committed
1232
1233
ilxTyConApp env tcon args =
   case lookupUFM tyPrimConTable (getUnique tcon) of
1234
	Just f  -> f args env
rrt's avatar
rrt committed
1235
        Nothing -> 
rrt's avatar
rrt committed
1236
1237
            (if isUnboxedTupleTyCon tcon then pprIlxUnboxedTupleTyConApp else pprIlxBoxedTyConApp)
              env tcon args
rrt's avatar
rrt committed
1238

rrt's avatar
rrt committed
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
pprIlxTyCon env tcon = nameReference env (getName tcon) <> ppr tcon
pprIlxUnboxedTupleTyConApp env tcon args 
  = text "/* unboxed */ value class" <+> pprIlxTyCon env tcon' <> pprTypeArgs ilxTypeL env non_void
  where 
   non_void = filter (not . isVoidIlxRepType) args
   tcon' = dataConTyCon (tupleCon Unboxed (length non_void)) 
pprIlxBoxedTyConApp env tcon args 
  = pprIlxNamedTyConApp env (pprIlxTyCon env tcon) args
pprIlxNamedTyConApp env tcon_text args 
  = text "class" <+> tcon_text <> pprTypeArgs ilxTypeR env args
rrt's avatar
rrt committed
1249
1250

-- Returns e.g: <Int32, Bool>
rrt's avatar
rrt committed
1251
1252
1253
-- Void-sized type arguments are _always_ eliminated, everywhere.
-- If the type constructor is an unboxed tuple type then it should already have
-- been adjusted to be the correct constructor.
rrt's avatar
rrt committed
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
pprTypeArgs f env tys = pprTypeArgs_aux f env (filter (not . isVoidIlxRepType) tys)

pprTypeArgs_aux f env []  = empty
pprTypeArgs_aux f env tys = angleBrackets (pprSepWithCommas (f env) tys)


pprTyVarBinders :: IlxEnv -> [TyVar] -> SDoc
-- Returns e.g: <class [mscorlib]System.Object> <class [mscorlib]System.Object>
-- plus a new environment with the type variables added.
pprTyVarBinders env [] = empty
pprTyVarBinders env tvs = angleBrackets (pprSepWithCommas (pprTyVarBinder_aux env) tvs)

pprTyVarBinder :: IlxEnv -> TyVar -> SDoc
pprTyVarBinder env tv = 
    if isIlxTyVar tv then 
       angleBrackets (pprTyVarBinder_aux env tv)
    else
       ilxComment (text "higher order tyvar" <+> pprId tv <+> 
1272
                         text ":" <+> ilxTypeR env (tyVarKind tv)) <+>
rrt's avatar
rrt committed
1273
1274
1275
1276
1277
1278
             ilxComment (text "omitted")
             -- parens (text "class [mscorlib]System.Object" <+> pprId tv)


pprTyVarBinder_aux env tv = 
   ilxComment (text "tyvar" <+> pprId tv <+> text ":" <+> 
1279
                        ilxTypeR env (tyVarKind tv)) <+>
rrt's avatar
rrt committed
1280
1281
1282
1283
1284
             (text "class [mscorlib]System.Object")

-- Only a subset of Haskell types can be generalized using the type quantification
-- of ILX
isIlxForAllKind h = 
1285
1286
1287
        ( h `eqKind` liftedTypeKind) ||
        ( h `eqKind` unliftedTypeKind) ||
        ( h `eqKind` openTypeKind)
rrt's avatar
rrt committed
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299

isIlxTyVar v = isTyVar v && isIlxForAllKind (tyVarKind v)

categorizeVars fvs = (ilx_tvs, non_ilx_tvs, vs)
         where
           (tvs, vs) = partition isTyVar fvs
           (ilx_tvs, non_ilx_tvs) = categorizeTyVars tvs

categorizeTyVars tyvs = partition isIlxTyVar tyvs

pprValArgTys ppr_ty env tys = parens (pprSepWithCommas (ppr_ty env) tys)

1300
pprId id = singleQuotes (ppr id)
rrt's avatar
rrt committed
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335

\end{code}			

%************************************************************************
%*									*
\subsection{IlxEnv}	
%*									*
%************************************************************************

\begin{code}
type IlxTyEnv = [TyVar]
emptyIlxTyEnv = []

-- Nb. There is currently no distinction between the kinds of type variables.
-- We may need to add this to print out correct numbers, esp. for
-- "forall" types
extendIlxTyEnvWithFreeTyVars env tyvars = env ++ mkIlxTyEnv tyvars -- bound by .closure x<...> in a closure declared with type parameters
extendIlxTyEnvWithFormalTyVars env tyvars = env ++ mkIlxTyEnv tyvars -- bound by "forall <...>" in a type
extendIlxTyEnvWithTyArgs env tyvars = env ++ mkIlxTyEnv tyvars -- bound by "<...>" in a closure implementing a universal type

formalIlxTyEnv tyvars = mkIlxTyEnv tyvars
mkIlxTyEnv tyvars = [ v | v <- tyvars, isIlxTyVar v ]

data HowBound = Top Module 	-- Bound in a modules
	      | Arg	-- Arguments to the enclosing closure
	      | CloVar Int -- A free variable of the enclosing closure
                           -- The int is the index of the field in the 
                           -- environment
	      | Local	-- Local let binding

-- The SDoc prints a unique name for the syntactic block we're currently processing,
-- e.g. Foo_bar_baz when inside closure baz inside closure bar inside module Foo.
data IlxEnv = IlxEnv (Module, IlxTyEnv, IdEnv HowBound,IdEnv (IlxEnv, StgRhs), Place,Bool)
type Place = (SDoc,SDoc)

1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
ilxTyVar  env tv
  = go 0 (ilxEnvTyEnv env)
  where
    go n [] 		    
      = pprTrace "ilxTyVar" (pprId tv <+> text "tv_env = { "
           <+> pprSepWithCommas
	         (\x -> pprId x <+> text ":" <+> ilxTypeR env (tyVarKind x)) 
               (ilxEnvTyEnv env) <+> text "}") 
        (char '!' <> pprId tv) 
    go n (x:xs)
      = {- pprTrace "go" (ppr (tyVarName tv) <+> ppr (tyVarName x)) -}
        (if tyVarName x== tyVarName tv then  char '!' <> int n <+> ilxComment (char '!' <> pprId tv) 
         else go (n+1) xs)
rrt's avatar
rrt committed
1349
1350
1351
1352
1353
1354
1355

emptyIlxEnv :: Bool -> Module -> IlxEnv
emptyIlxEnv trace mod = IlxEnv (mod, emptyIlxTyEnv, emptyVarEnv, emptyVarEnv, (ppr mod,empty),trace)

nextPlace place sdoc = place <> sdoc
usePlace  place sdoc = place <> sdoc

1356
ilxEnvModule (IlxEnv (m, _, _,  _, _,_)) = m
rrt's avatar
rrt committed
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
ilxEnvSetPlace (IlxEnv (m, tv_env, id_env,  bind_env, (mod,exact),tr)) sdoc 
   = IlxEnv (m, tv_env, id_env,  bind_env, (mod, sdoc),tr)
ilxEnvNextPlace (IlxEnv (m, tv_env, id_env,  bind_env, (mod,exact),tr)) sdoc 
   = IlxEnv (m, tv_env, id_env,  bind_env, (mod, nextPlace exact sdoc),tr)
ilxEnvQualifyByModule (IlxEnv (_, _, _, _,(mod,_),_)) sdoc = usePlace mod sdoc
ilxEnvQualifyByExact (IlxEnv (_, _, _, _,(mod,exact),_)) sdoc = usePlace mod sdoc <> usePlace exact sdoc

ilxPlaceStgBindDefault env = ilxEnvNextPlace env (text "D")
ilxPlaceStgRhsClosure env bndr = ilxEnvSetPlace env (ppr bndr) -- binders are already unique
ilxPlaceStgCaseScrut env = ilxEnvNextPlace env (text "S")

ilxPlaceAlt :: IlxEnv -> Int -> IlxEnv
ilxPlaceAlt env i = ilxEnvNextPlace env (text "a" <> int i)
ilxPlacePrimAltLit env i = ilxEnvNextPlace env (text "P" <> int i)
ilxMapPlaceArgs start f env args = [ f (ilxEnvNextPlace env (text "A" <> int i)) a | (i,a) <- [start..] `zip` args ]
ilxMapPlaceAlts f env alts = [ f (ilxPlaceAlt env i) alt | (i,alt) <- [1..] `zip` alts ]

extendIlxEnvWithFreeTyVars (IlxEnv (mod, tv_env, id_env,  bind_env, place,tr)) tyvars 
  = IlxEnv (mod, extendIlxTyEnvWithFreeTyVars tv_env tyvars,id_env,  bind_env, place,tr)

extendIlxEnvWithFormalTyVars (IlxEnv (mod, tv_env, id_env,  bind_env, place,tr)) tyvars 
  = IlxEnv (mod, extendIlxTyEnvWithFormalTyVars tv_env tyvars,id_env,  bind_env, place,tr)

extendIlxEnvWithTyArgs (IlxEnv (mod, tv_env, id_env,  bind_env, place,tr)) tyvars 
  = IlxEnv (mod, extendIlxTyEnvWithTyArgs tv_env tyvars,id_env,  bind_env, place,tr)

extendIlxEnvWithArgs :: IlxEnv -> [Var] -> IlxEnv
extendIlxEnvWithArgs (IlxEnv (mod, tv_env, id_env,  bind_env, place,tr)) args
  = IlxEnv (mod, extendIlxTyEnvWithTyArgs tv_env [tv      | tv <- args, isIlxTyVar tv],
            extendVarEnvList id_env [(v,Arg) | v  <- args, not (isIlxTyVar v)], 
	     bind_env, place,tr)

extendIlxEnvWithFreeVars (IlxEnv (mod, tv_env, id_env,  bind_env, place,tr)) args
  = IlxEnv (mod, 
            extendIlxTyEnvWithFreeTyVars tv_env [tv | tv <- args, isIlxTyVar tv],
            extendVarEnvList id_env (clovs 0 args), 
            bind_env, 
            place,tr)
   where
     clovs _ [] = []
     clovs n (x:xs) = if not (isIlxTyVar x) then (x,CloVar n):clovs (n+1) xs else clovs n xs

extendIlxEnvWithBinds env@(IlxEnv (mod, tv_env, id_env, bind_env, place,tr)) bnds
  = IlxEnv (mod, tv_env, id_env, 
            extendVarEnvList bind_env [(v,(env,rhs)) | (v,rhs) <- bnds], 
            place,tr)

extendIlxEnvWithLocals (IlxEnv (m, tv_env, id_env, bind_env, p,tr)) locals
  = IlxEnv (m, tv_env, 
            extendVarEnvList id_env [(v,Local) | (LocalId v,_) <- locals],
            extendVarEnvList bind_env [(v,(env,rhs)) | (LocalId v,Just (env,rhs)) <- locals], 
            p,tr)
extendIlxEnvWithTops env@(IlxEnv (m, tv_env, id_env, bind_env, place,tr)) mod binds
  = IlxEnv (m, tv_env, 
            extendVarEnvList id_env [(bndr,Top mod) | (bndr,rhs) <- binds], 
            extendVarEnvList bind_env [(bndr,(env, rhs)) | (bndr,rhs) <- binds], 
            place,tr)

formalIlxEnv (IlxEnv (m, tv_env, id_env, bind_env, place, tr)) tyvars 
  = IlxEnv (m, formalIlxTyEnv tyvars, id_env, bind_env, place, tr)

1418
1419
1420
1421
1422
1423
ilxEnvTyEnv :: IlxEnv -> IlxTyEnv
ilxEnvTyEnv (IlxEnv (_, tv_env, _,_,_,_)) = tv_env 
elemIlxTyEnv var env = elem var (ilxEnvTyEnv env )
elemIlxVarEnv var (IlxEnv (_, _, id_env,_,_,_)) = elemVarEnv var id_env 
lookupIlxVarEnv (IlxEnv (_, _, id_env,_,_,_)) var = lookupVarEnv id_env var
lookupIlxBindEnv (IlxEnv (_, _, _, bind_env,_,_)) var = lookupVarEnv bind_env var
rrt's avatar
rrt committed
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452

\end{code}


\begin{code}
type IlxLabel = SDoc

pprIlxLabel lbl = lbl

mkJoinLabel :: Id -> IlxLabel
mkJoinLabel v = text "J_" <> ppr v

mkAltLabel  :: Id -> Int -> IlxLabel
mkAltLabel v n = text "A" <> int n <> ppr v

ilxLabel :: IlxLabel -> SDoc
ilxLabel lbl =  line $$ (pprIlxLabel lbl <> colon)
\end{code}


%************************************************************************
%*									*
\subsection{Local pretty helper functions}
%*									*
%************************************************************************

\begin{code}
pprSepWithCommas :: (a -> SDoc) -> [a] -> SDoc
pprSepWithCommas pp xs = sep (punctuate comma (map pp xs))
1453
ilxComment pp   = text "/*" <+> pp <+> text "*/"
rrt's avatar
rrt committed
1454
1455
1456
1457
singleQuotes pp = char '\'' <> pp <> char '\''

line = text "// ----------------------------------"

rrt's avatar
rrt committed
1458
hscOptionQual = text ".i_"
1459

1460
nameReference env n
1461
  | isLocalName n = empty
1462
  | ilxEnvModule env == nameModule n  = text ""
1463
  | isHomeModule (nameModule n)   = moduleNameReference (moduleName (nameModule n))
1464
1465
1466
1467
1468
1469
1470
-- HACK: no Vanilla modules should be around, but they are!!  This
-- gets things working for the scenario "standard library linked as one
-- assembly with multiple modules + a one module program running on top of this"
-- Same applies to all other mentions of Vailla modules in this file
  | isVanillaModule (nameModule n)  && not inPrelude =  preludePackageReference
  | isVanillaModule (nameModule n)  && inPrelude =   moduleNameReference (moduleName (nameModule n))
-- end hack
1471
1472
  | otherwise = packageReference (modulePackage (nameModule n))

1473
packageReference p = brackets (singleQuotes (ppr p  <> hscOptionQual))
rrt's avatar
rrt committed
1474
moduleNameReference m = brackets ((text ".module") <+> (singleQuotes (pprModuleName m <> hscOptionQual <> text "o")))
rrt's avatar
rrt committed
1475

1476
1477
moduleReference env m
  | ilxEnvModule env   == m = text ""
1478
  | isHomeModule m = moduleNameReference (moduleName m)
1479
  -- See hack above
1480
1481
  | isVanillaModule m && not inPrelude =  preludePackageReference
  | isVanillaModule m && inPrelude =  moduleNameReference (moduleName m)
1482
  -- end hack
1483
  | otherwise  =  packageReference (modulePackage m)
rrt's avatar
rrt committed
1484

1485
1486
1487
preludePackageReference = packageReference preludePackage
inPrelude = preludePackage == opt_InPackage

rrt's avatar
rrt committed
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
------------------------------------------------
-- This code is copied from absCSyn/CString.lhs,
-- and modified to do the correct thing!  It's
-- still a mess though.  Also, still have to do the
-- right thing for embedded nulls.

pprFSInILStyle :: FAST_STRING -> SDoc
pprFSInILStyle fs = doubleQuotes (text (stringToC (_UNPK_ fs)))

stringToC   :: String -> String
-- Convert a string to the form required by C in a C literal string
-- Tthe hassle is what to do w/ strings like "ESC 0"...
stringToC ""  = ""
stringToC [c] = charToC c
stringToC (c:cs)
    -- if we have something "octifiable" in "c", we'd better "octify"
    -- the rest of the string, too.
  = if (c < ' ' || c > '~')
    then (charToC c) ++ (concat (map char_to_C cs))
    else (charToC c) ++ (stringToC cs)
  where
    char_to_C c | c == '\n' = "\\n"	-- use C escapes when we can
		| c == '\a' = "\\a"
		| c == '\b' = "\\b"	-- ToDo: chk some of these...
		| c == '\r' = "\\r"
		| c == '\t' = "\\t"
		| c == '\f' = "\\f"
		| c == '\v' = "\\v"
		| otherwise = '\\' : (trigraph (ord c))

charToC :: Char -> String
-- Convert a character to the form reqd in a C character literal
charToC c = if (c >= ' ' && c <= '~')	-- non-portable...
	    then case c of
		  '\'' -> "\\'"
		  '\\' -> "\\\\"
		  '"'  -> "\\\""
		  '\n' -> "\\n"
		  '\a' -> "\\a"
		  '\b' -> "\\b"
		  '\r' -> "\\r"
		  '\t' -> "\\t"
		  '\f' -> "\\f"
		  '\v' -> "\\v"
		  _    -> [c]
	    else '\\' : (trigraph (ord c))

trigraph :: Int -> String
trigraph n
  = [chr ((n `div` 100) `rem` 10 + ord '0'),
     chr ((n `div` 10) `rem` 10 + ord '0'),
     chr (n `rem` 10 + ord '0')]


\end{code}

%************************************************************************
%*									*
\subsection{PrimOps and Constructors}
%*									*
%************************************************************************

\begin{code}
----------------------------
-- Allocate a fresh constructor

ilxConApp env data_con args
  | isUnboxedTupleCon data_con
     = let tm_args' = filter (not. isVoidIlxRepType . stgArgType) tm_args in 
       case tm_args' of
        [h] -> 
          -- Collapse the construction of an unboxed tuple type where
          -- every element is zero-sized
            vcat (ilxMapPlaceArgs 0 pushArg env tm_args')
        _ -> 
          -- Minimize the construction of an unboxed tuple type, which
          -- may contain zero-sized elements.  Recompute all the 
          -- bits and pieces from the simpler case below for the new data
          -- type constructor....
1567
           let data_con' = tupleCon Unboxed (length tm_args') in 
rrt's avatar
rrt committed
1568
1569
1570
1571
1572
1573
1574
1575
1576
           let rep_ty_args' = filter (not . isVoidIlxRepType) rep_ty_args in 

           let tycon' = dataConTyCon data_con' in
           let (formal_tyvars', formal_tau_ty') = splitForAllTys (dataConRepType data_con') in 
           let (formal_arg_tys', _)     = splitFunTys formal_tau_ty' in
           let formal_env' 	     = formalIlxEnv env formal_tyvars' in 

           vcat [vcat (ilxMapPlaceArgs 0 pushArg env tm_args'),
	           sep [text "newobj void ",
1577
  		        ilxTyConApp env tycon' rep_ty_args',