Add vectorisation built-ins
[ghc-hetmet.git] / compiler / ilxGen / IlxGen.lhs
1 %
2 \section{Generate .NET extended IL}
3
4 \begin{code}
5 {-# OPTIONS -w #-}
6 -- The above warning supression flag is a temporary kludge.
7 -- While working on this module you are encouraged to remove it and fix
8 -- any warnings in the module. See
9 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
10 -- for details
11
12 module IlxGen( ilxGen ) where
13
14 #include "HsVersions.h"
15
16 import Char     ( ord, chr )
17 import StgSyn
18 import Id       ( idType, idName, isDeadBinder, idArity )
19 import Var      ( Var, Id, TyVar, isId, isTyVar, tyVarKind, tyVarName )
20 import VarEnv
21 import VarSet   ( isEmptyVarSet )
22 import TyCon    ( TyCon,  tyConPrimRep, isUnboxedTupleTyCon, tyConDataCons, 
23                   tyConTyVars, isDataTyCon, isAlgTyCon, tyConArity
24                 )
25 import Type     ( liftedTypeKind, openTypeKind, unliftedTypeKind,
26                   isUnLiftedType, isTyVarTy, mkTyVarTy, predTypeRep, pprType,
27                   splitForAllTys, splitFunTys, applyTy, applyTys, eqKind, tyVarsOfTypes
28                 )
29 import TypeRep  ( Type(..) )
30 import DataCon  ( isUnboxedTupleCon, dataConTyCon, dataConRepType, dataConRepArgTys, DataCon(..) )
31 import Literal  ( Literal(..) )
32 import PrelNames        -- Lots of keys
33 import PrimOp           ( PrimOp(..) )
34 import ForeignCall      ( CCallConv(..), ForeignCall(..), CCallSpec(..), CCallTarget(..), DNCallSpec(..) )
35 import TysWiredIn       ( mkTupleTy, tupleCon )
36 import PrimRep          ( PrimRep(..) )
37 import Name             ( nameModule, nameOccName, isExternalName, isInternalName, NamedThing(getName) )
38 import Subst            ( substTyWith )
39
40 import Module           ( Module, PackageName, ModuleName, moduleName, 
41                           modulePackage, basePackage,
42                           isHomeModule, isVanillaModule,
43                           pprModuleName, mkHomeModule, mkModuleName
44                         )
45
46 import UniqFM
47 import BasicTypes       ( Boxity(..) )
48 import CStrings         ( CLabelString, pprCLabelString )
49 import Outputable
50 import Char             ( ord )
51 import List             ( partition, elem, insertBy,any  )
52 import UniqSet
53
54 import TysPrim  ( foreignObjPrimTyCon, weakPrimTyCon, byteArrayPrimTyCon, mutableByteArrayPrimTyCon )
55
56 -- opt_SimplDoEtaReduction is used to help with assembly naming conventions for different
57 -- versions of compiled Haskell code.  We add a ".O" to all assembly and module 
58 -- names when this is set (because that's clue that -O was set).  
59 -- One day this will be configured by the command line.
60 import DynFlags ( opt_InPackage, opt_SimplDoEtaReduction )
61
62 import Util             ( lengthIs, equalLength )
63
64 \end{code}
65
66
67
68 %************************************************************************
69 %*                                                                      *
70 \subsection{Main driver}
71 %*                                                                      *
72 %************************************************************************
73
74 \begin{code}
75 ilxGen :: Module -> [TyCon] -> [(StgBinding,[Id])] -> SDoc
76         -- The TyCons should include those arising from classes
77 ilxGen mod tycons binds_w_srts
78   =  vcat [ text ".module '" <> (ppr (moduleName mod)) <> hscOptionQual <> text "o'",
79             text ".assembly extern 'mscorlib' {}",
80             vcat (map (ilxImportPackage topenv) (uniqSetToList import_packages)),
81             vcat (map (ilxImportModule topenv) (uniqSetToList import_modules)),
82             vcat (map (ilxImportTyCon topenv) (uniqSetToList import_tycons)),
83             vcat (map (ilxImportCCall topenv) (map snd (ufmToList import_ccalls))),
84             vcat (map (ilxTyCon topenv) data_tycons),
85             vcat (map (ilxBindClosures topenv) binds),
86             ilxTopBind mod topenv toppairs
87          ]
88     where
89       binds = map fst binds_w_srts
90       toppairs = ilxPairs binds
91       topenv = extendIlxEnvWithTops (emptyIlxEnv False mod) mod toppairs
92         -- Generate info from class decls as well
93       (import_packages,import_modules,import_tycons,import_ccalls) = importsBinds topenv binds (importsPrelude emptyImpInfo)
94       data_tycons = filter isDataTyCon tycons
95 \end{code}
96
97 %************************************************************************
98 %*                                                                      *
99 \subsection{Find Imports}
100 %*                                                                      *
101 %************************************************************************
102
103 \begin{code}
104
105 importsBinds :: IlxEnv -> [StgBinding] -> ImportsInfo -> ImportsInfo
106 importsBinds env binds = foldR (importsBind env) binds
107
108 importsNone :: ImportsInfo -> ImportsInfo
109 importsNone sofar = sofar
110
111 importsBind :: IlxEnv -> StgBinding -> ImportsInfo -> ImportsInfo
112 importsBind env (StgNonRec _ b rhs) = importsRhs env rhs.importsVar env b
113 importsBind env (StgRec _ pairs) = foldR (\(b,rhs) -> importsRhs env rhs . importsVar env b) pairs
114
115 importsRhs :: IlxEnv -> StgRhs -> ImportsInfo -> ImportsInfo
116 importsRhs env (StgRhsCon _ con args) = importsDataCon env con . importsStgArgs env args
117 importsRhs env (StgRhsClosure _ _ _ _ args body) = importsExpr env body. importsVars env args
118
119 importsExpr :: IlxEnv -> StgExpr -> ImportsInfo -> ImportsInfo
120 importsExpr env (StgLit _) = importsNone
121 importsExpr env (StgApp f args) = importsVar env f.importsStgArgs env args
122 importsExpr env (StgConApp con args) = importsDataCon env con.importsStgArgs env args
123 importsExpr env (StgOpApp (StgFCallOp (CCall (CCallSpec (StaticTarget c) cc _)) _) args rty)
124   = addCCallInfo (c,cc, map stgArgType tm_args, rty) . importsStgArgs env args
125   where 
126     (ty_args,tm_args) = splitTyArgs1 args 
127
128 importsExpr env (StgOpApp _ args res_ty) = importsType env res_ty. importsStgArgs env args
129
130
131 importsExpr env (StgSCC _ expr) = importsExpr env expr
132 importsExpr env (StgCase scrut _ _ bndr _ alts)
133   = importsExpr env scrut. imports_alts alts. importsVar env bndr
134    where
135     imports_alts (StgAlgAlts _ alg_alts deflt)  -- The Maybe TyCon part is dealt with 
136                                                 -- by the case-binder's type
137       = foldR imports_alg_alt alg_alts .  imports_deflt deflt
138        where
139         imports_alg_alt (con, bndrs, _, rhs)
140           = importsExpr env rhs . importsDataCon env con. importsVars env bndrs
141
142     imports_alts (StgPrimAlts _ alg_alts deflt)
143       = foldR imports_prim_alt alg_alts . imports_deflt deflt
144        where
145         imports_prim_alt (_, rhs) = importsExpr env rhs
146     imports_deflt StgNoDefault = importsNone
147     imports_deflt (StgBindDefault rhs) = importsExpr env rhs
148
149
150 importsExpr env (StgLetNoEscape _ _ bind body) = importsExpr env (StgLet bind body)
151 importsExpr env (StgLet bind body)
152   = importsBind env bind .  importsExpr env body
153
154 importsApp env v args = importsVar env v.  importsStgArgs env args
155 importsStgArgs env args = foldR (importsStgArg env) args
156
157 importsStgArg :: IlxEnv -> StgArg -> ImportsInfo -> ImportsInfo
158 importsStgArg env (StgTypeArg ty) = importsType env ty
159 importsStgArg env (StgVarArg v) = importsVar env v
160 importsStgArg env _ = importsNone
161
162 importsVars env vs = foldR (importsVar env) vs
163 importsVar env v = importsName env (idName v). importsType env (idType v)
164
165 importsName env n
166    | isInternalName n = importsNone
167    | ilxEnvModule env == nameModule n = importsNone
168    | isHomeModule (nameModule n) =  addModuleImpInfo (moduleName (nameModule n))
169 -- See HACK below
170    | isVanillaModule (nameModule n)  && not inPrelude =  importsPrelude
171    | isVanillaModule (nameModule n)  && inPrelude =   addModuleImpInfo (moduleName (nameModule n))
172 -- End HACK
173    | otherwise = addPackageImpInfo (modulePackage (nameModule n))
174
175
176 importsPrelude | inPrelude = addModuleImpInfo (mkModuleName "PrelGHC")
177                | otherwise = addPackageImpInfo basePackage
178
179
180 importsType :: IlxEnv -> Type -> ImportsInfo -> ImportsInfo
181 importsType env ty = importsType2 env (deepIlxRepType ty)
182
183 importsType2 :: IlxEnv -> Type -> ImportsInfo -> ImportsInfo
184 importsType2 env (AppTy f x) =  importsType2 env f . importsType2 env x
185 importsType2 env (TyVarTy _) = importsNone
186 importsType2 env (TyConApp tc args) =importsTyCon env tc . importsTypeArgs2 env args
187 importsType2 env (FunTy arg res) =  importsType env arg .  importsType2 env res
188 importsType2 env (ForAllTy tv body_ty) =  importsType2 env body_ty
189 importsType2 env (NoteTy _ ty) = importsType2 env ty
190 importsType2 _ _ = panic "IlxGen.lhs: importsType2 ty"
191 importsTypeArgs2 env tys = foldR (importsType2 env) tys
192
193 importsDataCon env dcon = importsTyCon env (dataConTyCon dcon)
194
195 importsTyCon env tc | (not (isDataTyCon tc) || 
196                    isInternalName (getName tc) || 
197                    ilxEnvModule env == nameModule (getName tc)) = importsNone
198 importsTyCon env tc | otherwise = importsName env (getName tc) . addTyConImpInfo tc .
199                                     foldR (importsTyConDataCon env) (tyConDataCons tc)
200
201
202 importsTyConDataCon :: IlxEnv -> DataCon -> ImportsInfo -> ImportsInfo
203 importsTyConDataCon env dcon = foldR (importsTyConDataConType env) (filter (not . isVoidIlxRepType) (dataConRepArgTys dcon))
204
205 importsTyConDataConType :: IlxEnv -> Type -> ImportsInfo -> ImportsInfo
206 importsTyConDataConType env ty = importsTyConDataConType2 env (deepIlxRepType ty)
207
208 importsTyConDataConType2 :: IlxEnv -> Type -> ImportsInfo -> ImportsInfo
209 importsTyConDataConType2 env (AppTy f x) =  importsTyConDataConType2 env f . importsTyConDataConType2 env x
210 importsTyConDataConType2 env (TyVarTy _) = importsNone
211 importsTyConDataConType2 env (TyConApp tc args) = importsTyConDataConTypeTyCon env tc . importsTyConDataConTypeArgs2 env args
212 importsTyConDataConType2 env (FunTy arg res) = importsTyConDataConType env arg .  importsTyConDataConType2 env res
213 importsTyConDataConType2 env (ForAllTy tv body_ty) = importsTyConDataConType2 env body_ty
214 importsTyConDataConType2 env (NoteTy _ ty) = importsTyConDataConType2 env ty
215 importsTyConDataConType2 _ _ = panic "IlxGen.lhs: importsTyConDataConType2 ty"
216 importsTyConDataConTypeArgs2 env tys = foldR (importsTyConDataConType2 env) tys
217
218 importsTyConDataConTypeTyCon env tc | (not (isDataTyCon tc) || 
219                    isInternalName (getName tc) || 
220                    ilxEnvModule env == nameModule (getName tc)) = importsNone
221 importsTyConDataConTypeTyCon env tc | otherwise = importsName env (getName tc)
222
223
224 type StaticCCallInfo = (CLabelString,CCallConv,[Type],Type)
225 type ImportsInfo = (UniqSet PackageName, UniqSet ModuleName, UniqSet TyCon, UniqFM StaticCCallInfo)
226    -- (Packages, Modules, Datatypes, Imported CCalls)
227
228 emptyImpInfo :: ImportsInfo
229 emptyImpInfo = (emptyUniqSet, emptyUniqSet, emptyUniqSet, emptyUFM)
230 addPackageImpInfo p (w,x,y,z) = (addOneToUniqSet w p, x, y,z)
231 addModuleImpInfo m (w,x,y,z) = (w, addOneToUniqSet x m, y,z)
232 addTyConImpInfo tc (w,x,y,z) = (w, x, addOneToUniqSet y tc,z)
233 addCCallInfo info@(nm,a,b,c) (w,x,y,z) = (w, x, y,addToUFM z nm info)
234
235 ilxImportTyCon :: IlxEnv -> TyCon -> SDoc
236 ilxImportTyCon env tycon | isDataTyCon tycon = ilxTyConDef True env tycon
237 ilxImportTyCon _ _ | otherwise =  empty
238
239 ilxImportPackage :: IlxEnv -> PackageName -> SDoc
240 ilxImportPackage _ p = text ".assembly extern" <+> singleQuotes (ppr p <> hscOptionQual) <+> text "{ }"
241
242 ilxImportModule :: IlxEnv -> ModuleName -> SDoc
243 ilxImportModule _ m = text ".module extern" <+> singleQuotes (ppr m <> hscOptionQual <> text "o")
244
245 -- Emit a P/Invoke declaration for the imported C function
246 -- TODO: emit the right DLL name
247 ilxImportCCall :: IlxEnv -> StaticCCallInfo -> SDoc
248 ilxImportCCall env (c,cc,args,ret) = 
249     text ".method static assembly pinvokeimpl" <+> 
250     parens (doubleQuotes (text "HSstd_cbits.dll") <+> text "cdecl") <+> retdoc <+> singleQuotes (pprCLabelString c) <+> 
251     pprCValArgTys ilxTypeL env (map deepIlxRepType (filter (not. isVoidIlxRepType) args)) <+> 
252     text "unmanaged preservesig { }"
253   where 
254     retdoc = 
255           if isVoidIlxRepType ret then text "void" 
256           else ilxTypeR env (deepIlxRepType ret)
257
258
259 \end{code}
260
261 %************************************************************************
262 %*                                                                      *
263 \subsection{Type declarations}
264 %*                                                                      *
265 %************************************************************************
266
267 \begin{code}
268
269
270 ilxTyCon :: IlxEnv -> TyCon -> SDoc
271 ilxTyCon env tycon =  ilxTyConDef False env tycon
272
273 -- filter to get only dataTyCons?
274 ilxTyConDef importing env tycon = 
275         vcat [empty $$ line,
276               text ".classunion" <+> (if importing then text "import" else empty) <+> tycon_ref <+> tyvars_text <+> super_text   <+> alts_text]
277    where
278      tycon_ref =  nameReference env (getName tycon)  <> (ppr tycon)
279      super_text = if importing then empty else text "extends thunk" <> angleBrackets (text "class" <+> tycon_ref)
280      tyvars = tyConTyVars tycon
281      (ilx_tvs, _) = categorizeTyVars tyvars
282      alts_env = extendIlxEnvWithFormalTyVars env ilx_tvs 
283      tyvars_text = pprTyVarBinders alts_env ilx_tvs 
284      alts = vcat (map (pprIlxDataCon alts_env) (tyConDataCons tycon))
285      alts_text = nest 2 (braces alts)
286
287 pprIlxDataCon env dcon =
288         text ".alternative" <+> pprId dcon <+> 
289         parens (pprSepWithCommas (ilxTypeL env) (map deepIlxRepType (filter (not. isVoidIlxRepType) (dataConRepArgTys dcon))))
290 \end{code}
291
292
293 %************************************************************************
294 %*                                                                      *
295 \subsection{Getting the .closures and literals out}                     *
296 %************************************************************************
297
298 \begin{code}
299
300 ilxBindClosures :: IlxEnv -> StgBinding -> SDoc
301 ilxBindClosures env (StgNonRec _ b rhs) = ilxRhsClosures env (b,rhs)
302 ilxBindClosures env (StgRec _ pairs)  
303   = vcat (map (ilxRhsClosures new_env) pairs)
304   where
305      new_env = extendIlxEnvWithBinds env pairs
306
307 ---------------
308 ilxRhsClosures _ (_, StgRhsCon _ _ _)
309   = empty
310
311 ilxRhsClosures env (bndr, StgRhsClosure _ _ fvs upd args rhs)
312   = vcat [ilxExprClosures next_env rhs,
313
314          empty $$ line,
315          kind_text <+> singleQuotes cloname <+>  free_vs_text,
316          nest 2 (braces (
317             nest 2 (vcat [empty,
318                           vcat [text ".apply" <+> closure_sig_text,
319                                 body_text
320                           ],
321                           empty
322                     ])
323                 ))
324     ]
325   where
326     kind_of_thing = case upd of
327                           Updatable -> ASSERT( null args ) ".thunk"
328                           otherwise -> ".closure"
329     kind_text = text kind_of_thing 
330                 
331     cloname = ilxEnvQualifyByModule env (ppr bndr)
332     next_env = ilxPlaceStgRhsClosure env bndr 
333     (free_vs_text,env_with_fvs) = pprFreeBinders next_env fvs
334
335
336     closure_sig_text =     
337       vcat [ text "()",
338              (case args of 
339                []        -> empty
340                otherwise -> args_text),
341              text "-->" <+>  rty_text]
342
343     (args_text,env_with_args) = pprArgBinders env_with_fvs args
344
345         -- Find the type returned, from the no. of args and the type of "bndr"
346     rty_text = 
347       case retType env_with_fvs (idIlxRepType bndr) args of
348        Just (env,ty) -> 
349           if isVoidIlxRepType ty  then  (text "void")
350           else ilxTypeR env ty 
351        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))
352
353     -- strip off leading ForAll and Fun type constructions
354     -- up to the given number of arguments, extending the environment as
355     -- we go.  
356     retType env ty [] = Just (env, ty)
357     retType env (ForAllTy tv ty) (arg:args) = retType (extendIlxEnvWithTyArgs env [tv]) ty args
358     retType env (FunTy l r) (arg:args) = retType env r args
359     retType _ _ _  = Nothing
360
361         -- Code for the local variables
362     locals = ilxExprLocals env_with_args rhs
363
364     env_with_locals = extendIlxEnvWithLocals env_with_args locals
365
366         -- Code for the body of the main apply method
367     body_code = vcat [empty,
368                       pprIlxLocals env_with_args locals,
369                       ilxExpr (IlxEEnv env_with_locals (mkUniqSet (filter (not.isTyVar) args))) rhs Return,
370                       empty
371                 ]
372
373     body_text = nest 2 (braces (text ".maxstack 100" <+> nest 2 body_code))
374
375
376 pprIlxLocals env [] = empty
377 pprIlxLocals env vs 
378    = text ".locals" <+> parens (pprSepWithCommas (pprIlxLocal env) (filter nonVoidLocal vs))
379   where
380     nonVoidLocal (LocalId v,_) = not (isVoidIlxRepId v)
381     nonVoidLocal _ = True
382
383 pprIlxLocal env (LocalId v,_) = ilxTypeL env (idIlxRepType v) <+> pprId v
384 pprIlxLocal env (LocalSDoc (ty,doc,pin),_) = ilxTypeL env (deepIlxRepType ty) <+> (if pin then text "pinned" else empty) <+> doc
385
386
387 pprFreeBinders env fvs 
388     = (ilx_tvs_text <+> vs_text, env2)
389     where   
390        (free_ilx_tvs, _,free_vs) = categorizeVars fvs
391        real_free_vs = filter (not . isVoidIlxRepId) free_vs
392         -- ignore the higher order type parameters for the moment
393        env1 = extendIlxEnvWithFreeTyVars env free_ilx_tvs 
394        ilx_tvs_text = pprTyVarBinders env1 free_ilx_tvs
395        vs_text = parens (pprSepWithCommas ppr_id real_free_vs)
396        ppr_id v = ilxTypeL env1 (idIlxRepType v) <+> pprId v 
397        env2 = extendIlxEnvWithFreeVars env1 real_free_vs 
398
399 pprIdBinder env v = parens (ilxTypeL env (idIlxRepType v) <+> pprId v)
400
401         -- Declarations for the arguments of the main apply method
402 pprArgBinders env [] = (empty,env)
403 pprArgBinders env (arg:args)
404     = (arg_text <+> rest_text, res_env)
405    where 
406      (arg_text,env') = pprArgBinder env arg
407      (rest_text,res_env) = pprArgBinders env' args 
408
409 -- We could probably omit some void argument binders, but
410 -- don't...
411 pprArgBinder env arg 
412   | isVoidIlxRepId arg = (text "()", extendIlxEnvWithArgs env [arg])
413   | otherwise 
414       = if isTyVar arg then 
415          let env' = extendIlxEnvWithTyArgs env [arg] in 
416          (pprTyVarBinder env' arg, env')
417       else (pprIdBinder env arg,extendIlxEnvWithArgs env [arg])
418
419 --------------
420 -- Compute local variables used by generated method.
421 -- The names of some generated locals are recorded as SDocs.
422
423 data LocalSpec = LocalId Id | LocalSDoc (Type, SDoc, Bool)  -- flag is for pinning
424
425 ilxExprLocals :: IlxEnv -> StgExpr -> [(LocalSpec,Maybe (IlxEnv,StgRhs))]
426 ilxExprLocals env (StgLet bind body)              = ilxBindLocals env bind ++ ilxExprLocals env body
427 ilxExprLocals env (StgLetNoEscape _ _ bind body)  = ilxBindLocals env bind ++ ilxExprLocals env body  -- TO DO????
428 ilxExprLocals env (StgCase scrut _ _ bndr _ alts) 
429      = ilxExprLocals (ilxPlaceStgCaseScrut env) scrut ++ 
430        (if isDeadBinder bndr then [] else [(LocalId bndr,Nothing)]) ++ 
431        ilxAltsLocals env alts
432 ilxExprLocals env (StgOpApp (StgFCallOp fcall _) args _) 
433      = concat (ilxMapPlaceArgs 0 ilxCCallArgLocals env args)
434 ilxExprLocals _ _  = []
435
436 -- Generate locals to use for pinning arguments as we cross the boundary
437 -- to C.
438 ilxCCallArgLocals env (StgVarArg v) | pinCCallArg v = 
439    [(LocalSDoc (idType v, ilxEnvQualifyByExact env (ppr v) <> text "pin", True), Nothing)]
440 ilxCCallArgLocals _ _ | otherwise = []
441
442 ilxBindLocals env (StgNonRec _ b rhs) = [(LocalId b,Just (env, rhs))]
443 ilxBindLocals env (StgRec _ pairs)    = map (\(x,y) -> (LocalId x,Just (env, y))) pairs
444
445 ilxAltsLocals env (StgAlgAlts  _ alts deflt) = ilxDefltLocals env deflt ++ concat (ilxMapPlaceAlts ilxAlgAltLocals env alts)
446 ilxAltsLocals env (StgPrimAlts _ alts deflt) = ilxDefltLocals env deflt ++ concat (ilxMapPlaceAlts ilxPrimAltLocals env alts)
447
448 ilxAlgAltLocals env (_, bndrs, _, rhs) = map (\x -> (LocalId x,Nothing)) (filter (\v -> isId v && not (isDeadBinder v)) bndrs) ++ ilxExprLocals env rhs
449 ilxPrimAltLocals env (_, rhs)          = ilxExprLocals env rhs
450
451 ilxDefltLocals _ StgNoDefault   = []
452 ilxDefltLocals env (StgBindDefault rhs) = ilxExprLocals (ilxPlaceStgBindDefault env) rhs
453
454 --------------
455 ilxExprClosures :: IlxEnv -> StgExpr -> SDoc
456 ilxExprClosures env (StgApp _ args)
457   = vcat (ilxMapPlaceArgs 0 (ilxArgClosures) env args)  -- get strings
458 ilxExprClosures env (StgConApp _ args)
459   = vcat (ilxMapPlaceArgs 0 (ilxArgClosures) env args) -- get strings
460 ilxExprClosures env (StgOpApp _ args _)
461   = vcat (ilxMapPlaceArgs 0 (ilxArgClosures) env args) -- get strings
462 ilxExprClosures env (StgLet bind body)
463   = ilxBindClosures env bind $$ ilxExprClosures (extendIlxEnvWithBinds env (ilxPairs1 bind)) body
464 ilxExprClosures env (StgLetNoEscape _ _ bind body)  -- TO DO????
465   = ilxBindClosures env bind $$ ilxExprClosures (extendIlxEnvWithBinds env (ilxPairs1 bind)) body
466 ilxExprClosures env (StgCase scrut _ _ _ _ alts)
467   = ilxExprClosures (ilxPlaceStgCaseScrut env) scrut $$ ilxAltsClosures env alts 
468 ilxExprClosures env (StgLit lit) 
469   = ilxGenLit env lit 
470 ilxExprClosures _ _ 
471   = empty
472
473 ilxAltsClosures env (StgAlgAlts _ alts deflt)
474   = vcat [ilxExprClosures (ilxPlaceAlt env i) rhs | (i,(_, _, _, rhs))  <- [1..] `zip` alts]
475     $$ 
476     ilxDefltClosures env deflt
477
478 ilxAltsClosures env (StgPrimAlts _ alts deflt)
479   = vcat [ilxExprClosures (ilxPlaceAlt env i) rhs | (i,(_, rhs)) <- [1..] `zip` alts]
480     $$ 
481     vcat [ ilxGenLit (ilxPlacePrimAltLit env i) lit | (i,(lit,_)) <- [1..] `zip` alts]
482     $$ 
483     ilxDefltClosures  env deflt
484
485 ilxDefltClosures env (StgBindDefault rhs) = ilxExprClosures (ilxPlaceStgBindDefault env) rhs
486 ilxDefltClosures _ StgNoDefault   = empty
487
488 ilxArgClosures env (StgLitArg lit) = ilxGenLit env lit 
489 ilxArgClosures _ _ = empty
490
491
492
493 ilxGenLit env (MachStr fs) 
494   = vcat [text ".field static assembly char "  <+> singleQuotes nm <+> text "at" <+> nm <> text "L",
495           text ".data" <+> nm <> text "L" <+> text "= char *("  <> pprFSInILStyle fs  <> text ")"
496          ]
497  where
498    nm = ilxEnvQualifyByExact env (text "string")
499
500 ilxGenLit  _ _ = empty
501
502 \end{code}
503
504
505 %************************************************************************
506 %*                                                                      *
507 \subsection{Generating code}
508 %*                                                                      *
509 %************************************************************************
510
511
512 \begin{code}
513
514 -- Environment when generating expressions
515 data IlxEEnv = IlxEEnv IlxEnv (UniqSet Id)
516
517 data Sequel = Return | Jump IlxLabel
518
519 ilxSequel Return     = text "ret"
520 ilxSequel (Jump lbl) = text "br" <+> pprIlxLabel lbl
521
522 isReturn Return = True
523 isReturn (Jump _) = False
524
525
526 ilxExpr :: IlxEEnv -> StgExpr 
527         -> Sequel       -- What to do at the end
528         -> SDoc
529
530 ilxExpr (IlxEEnv env _) (StgApp fun args) sequel
531   = ilxFunApp env fun args (isReturn sequel) $$ ilxSequel sequel
532
533 -- ilxExpr eenv (StgLit lit) sequel
534 ilxExpr (IlxEEnv env _) (StgLit lit) sequel
535   = pushLit env lit $$ ilxSequel sequel
536
537 -- ilxExpr eenv (StgConApp data_con args) sequel
538 ilxExpr (IlxEEnv env _) (StgConApp data_con args) sequel
539   = text " /* ilxExpr:StgConApp */ " <+>  ilxConApp env data_con args $$ ilxSequel sequel
540
541 -- ilxExpr eenv (StgPrimApp primop args _) sequel
542 ilxExpr (IlxEEnv env _) (StgOpApp (StgFCallOp fcall _) args ret_ty) sequel
543   = ilxFCall env fcall args ret_ty $$ ilxSequel sequel
544
545 ilxExpr (IlxEEnv env _) (StgOpApp (StgPrimOp primop) args ret_ty) sequel
546   = ilxPrimOpTable primop args env $$ ilxSequel sequel
547
548 --BEGIN TEMPORARY
549 -- The following are versions of a peephole optimizations for "let t = \[] t2[fvs] in t"
550 -- I think would be subsumed by a general treatmenet of let-no-rec bindings??
551 ilxExpr eenv@(IlxEEnv env _) (StgLet (StgNonRec _ bndr (StgRhsClosure _ _ _ _ [] rhs)) (StgApp fun [])) sequel 
552               | (bndr == fun && null (ilxExprLocals env rhs)) -- TO DO???
553   = ilxExpr eenv rhs sequel
554 ilxExpr eenv@(IlxEEnv env _) (StgLetNoEscape _ _ (StgNonRec _ bndr (StgRhsClosure _ _ _ _ [] rhs)) (StgApp fun [])) sequel 
555               | (bndr == fun && null (ilxExprLocals env rhs)) -- TO DO???
556   = ilxExpr eenv rhs sequel
557 --END TEMPORARY
558
559 ilxExpr eenv (StgLet bind body) sequel
560   = ilxBind eenv bind $$ ilxExpr eenv body sequel
561
562
563 ilxExpr eenv (StgLetNoEscape _ _ bind body) sequel -- TO DO???
564   = ilxBind eenv bind $$ ilxExpr eenv body sequel
565
566 -- StgCase: Special case 1 to avoid spurious branch.
567 ilxExpr eenv@(IlxEEnv env live) (StgCase (StgApp fun args) live_in_case _live_in_alts bndr _ alts) sequel
568   = vcat [ilxWipe env (uniqSetToList (live `minusUniqSet` live_in_case)),
569           ilxFunApp (ilxPlaceStgCaseScrut env) fun args False,
570           --ilxWipe env (uniqSetToList (live_in_case `minusUniqSet` _live_in_alts)),
571           --ilxAlts (IlxEEnv env _live_in_alts) bndr alts sequel
572           ilxAlts (IlxEEnv env live_in_case) bndr alts sequel
573     ]
574
575 -- StgCase: Special case 2 to avoid spurious branch.
576 ilxExpr eenv@(IlxEEnv env live) (StgCase (StgOpApp (StgPrimOp primop) args ret_ty) live_in_case _live_in_alts bndr _ alts) sequel
577   = vcat [ilxWipe env (uniqSetToList (live `minusUniqSet` live_in_case)),
578           ilxPrimOpTable primop args (ilxPlaceStgCaseScrut env),
579           --ilxWipe env (uniqSetToList (live_in_case `minusUniqSet` _live_in_alts)),
580           --ilxAlts (IlxEEnv env _live_in_alts) bndr alts sequel
581           ilxAlts (IlxEEnv env live_in_case) bndr alts sequel
582     ]
583
584 -- StgCase: Normal case.
585 ilxExpr eenv@(IlxEEnv env live) (StgCase scrut live_in_case _live_in_alts bndr _ alts) sequel
586   = vcat [ilxWipe env (uniqSetToList (live `minusUniqSet` live_in_case)),
587           ilxExpr (IlxEEnv (ilxPlaceStgCaseScrut env) live_in_case) scrut (Jump join_lbl),
588           ilxLabel join_lbl,
589           --ilxWipe env (uniqSetToList (live_in_case `minusUniqSet` _live_in_alts)),
590           --ilxAlts (IlxEEnv env _live_in_alts) bndr alts sequel
591           ilxAlts (IlxEEnv env live_in_case) bndr alts sequel
592     ]
593   where
594     join_lbl = mkJoinLabel bndr
595
596 ilxExpr _ _ _ 
597   = panic "ilxExpr:  Patterns not matched:(IlxEEnv _ _) (StgSCC _ _) _ (IlxEEnv _ _) (StgLam _ _ _) _"
598
599
600 -- Wipe out locals and arguments that are no longer in use, to
601 -- prevent space leaks. If the VM is implemented 100% correctly then
602 -- this should probably not be needed, as the live variable analysis
603 -- in the JIT would tell the GC that these locals and arguments are
604 -- no longer live.  However I'm putting it in here so we can
605 -- check out if it helps.
606 --
607 -- Also, in any case this doesn't capture everything we need.  e.g.
608 -- when making a call:
609 --     case f x of ...
610 -- where x is not used in the alternatives, then the variable x
611 -- is no longer live from the point it is transferred to the call
612 -- onwards.  We should expunge "live_in_case - live_in_alts" right
613 -- before making the call, not after returning from the call....
614 --
615 -- Strictly speaking we also don't need to do this for primitive
616 -- values such as integers and addresses, i.e. things not
617 -- mapped down to GC'able objects.
618 ilxWipe env ids 
619    = vcat (map (ilxWipeOne env) (filter (not.isVoidIlxRepId) ids))
620
621 ilxWipeOne env id
622    = case lookupIlxVarEnv env id of
623           Just Local  -> text "ldloca " <+> pprId id <+> text "initobj.any" <+> (ilxTypeL env (idIlxRepType id))
624           Just Arg   -> text "deadarg " <+> pprId id <+> text "," <+> (ilxTypeL env (idIlxRepType id))
625           Just (CloVar _)  -> ilxComment (text "not yet wiping closure variable" <+> pprId id )
626           _ -> ilxComment (text "cannot wipe non-local/non-argument" <+> pprId id )
627   where 
628       
629
630 ----------------------
631
632 ilxAlts :: IlxEEnv -> Id -> StgCaseAlts -> Sequel -> SDoc
633 ilxAlts (IlxEEnv env live) bndr alts sequel
634         -- At the join label, the result is on top
635         -- of the stack
636   = vcat [store_in_bndr,
637           do_case_analysis alts
638     ]
639   where
640     scrut_rep_ty = deepIlxRepType (idType bndr)
641
642     store_in_bndr | isDeadBinder bndr = empty
643                   | isVoidIlxRepId bndr 
644                         = ilxComment (text "ignoring store of zero-rep value to be analyzed")
645                   | otherwise         = text "dup" $$ (text "stloc" <+> pprId bndr)
646
647     do_case_analysis (StgAlgAlts _ []    deflt)
648         = do_deflt deflt
649
650     do_case_analysis (StgAlgAlts _ args deflt) 
651         = do_alg_alts ([1..] `zip` args) deflt
652
653     do_case_analysis (StgPrimAlts _ alts deflt)
654         = do_prim_alts ([1..] `zip` alts) $$ do_deflt deflt
655
656     do_alg_alts [(i, alt@(data_con,bndrs,used_flags, rhs))] StgNoDefault | isUnboxedTupleCon data_con
657       -- Collapse the analysis of unboxed tuples where 
658       -- some or all elements are zero-sized
659       --
660       -- TO DO: add bndrs to set of live variables
661           = case bndrs' of
662                   [h] -> bind_collapse bndrs used_flags <+> do_rhs_no_pop alt_env rhs
663                   _ -> bind_components alt_env dcon' bndrs 0 used_flags <+> do_rhs alt_env rhs
664            where 
665             bndrs' = filter (not. isVoidIlxRepId) bndrs
666             -- Replacement unboxed tuple type constructor, used if any of the
667             -- arguments have zero-size and more than one remains.
668             dcon'  = tupleCon Unboxed (length bndrs')
669
670             alt_env = IlxEEnv (ilxPlaceAlt env i) live
671             --alt_env = IlxEEnv (ilxPlaceAlt env i) 
672
673             bind_collapse [] _ = panic "bind_collapse: unary element not found"
674             bind_collapse (h:t) (is_used:used_flags) 
675                 | isVoidIlxRepId h = ilxComment (text "zero-rep binding eliminated") <+> (bind_collapse t used_flags)
676                 | not is_used = ilxComment (text "not used") <+> text "pop"
677                 | otherwise = text "stloc" <+> pprId h
678
679
680     do_alg_alts [(i, alt@(data_con,bndrs,used_flags, rhs))] StgNoDefault 
681             = vcat [text "castdata" <+> sep [ilxTypeR env scrut_rep_ty <> comma,
682                                              ilxConRef env data_con],
683                 do_alg_alt (IlxEEnv (ilxPlaceAlt env i) live) alt
684               ]
685
686     do_alg_alts alts deflt
687         = vcat [text "datacase" <+> sep [ilxTypeR env scrut_rep_ty,text ",",
688                                          pprSepWithCommas pp_case labels_w_alts],
689                 do_deflt deflt,
690                 vcat (map do_labelled_alg_alt labels_w_alts)
691           ]
692         where
693           pp_case (i, (lbl, (data_con, _, _, _))) = parens (ilxConRef env data_con <> comma <> pprIlxLabel lbl)
694           labels_w_alts = [(i,(mkAltLabel bndr i, alt)) | (i, alt) <- alts]
695
696     do_prim_alts [] = empty
697     do_prim_alts ((i, (lit,alt)) : alts) 
698         = vcat [text "dup", pushLit (ilxPlacePrimAltLit env i) lit, text "bne.un" <+> pprIlxLabel lbl, 
699                 do_rhs (IlxEEnv (ilxPlaceAlt env i) live) alt, 
700                 ilxLabel lbl, do_prim_alts alts]
701         where
702           lbl = mkAltLabel bndr i
703
704     do_labelled_alg_alt (i,(lbl, alt)) 
705         = ilxLabel lbl $$ do_alg_alt (IlxEEnv (ilxPlaceAlt env i) live) alt
706
707     do_alg_alt alt_eenv (data_con, bndrs, used_flags, rhs) 
708       = vcat [bind_components alt_eenv data_con bndrs 0 used_flags,
709               do_rhs alt_eenv rhs
710              ]
711
712     bind_components alt_eenv data_con [] n _ = empty
713     bind_components alt_eenv data_con (h:t) n (is_used:used_flags) 
714        | isVoidIlxRepId h 
715              -- don't increase the count in this case
716              = ilxComment (text "zero-rep binding eliminated") 
717                <+> bind_components alt_eenv data_con t n used_flags
718        | otherwise 
719              = bind_component alt_eenv data_con h is_used n 
720                <+> bind_components alt_eenv data_con t (n + 1) used_flags
721
722     bind_component alt_eenv@(IlxEEnv alt_env _) data_con bndr is_used reduced_fld_no 
723         | not is_used 
724             = ilxComment (text "not used")
725         | isVoidIlxRepId bndr 
726             = ilxComment (text "ignoring bind of zero-rep variable")
727         | otherwise   = vcat [text "dup",
728                               ld_data alt_env data_con reduced_fld_no bndr,
729                               text "stloc" <+> pprId bndr]
730
731     do_deflt (StgBindDefault rhs) = do_rhs (IlxEEnv (ilxPlaceStgBindDefault env) live) rhs
732     do_deflt StgNoDefault         = empty
733
734     do_rhs alt_eenv rhs  
735         | isVoidIlxRepId bndr = do_rhs_no_pop alt_eenv rhs     -- void on the stack, nothing to pop
736         | otherwise = text "pop" $$ do_rhs_no_pop alt_eenv rhs  -- drop the value
737
738     do_rhs_no_pop alt_env rhs = ilxExpr alt_env rhs sequel
739
740     ld_data alt_env data_con reduced_fld_no bndr
741       | isUnboxedTupleCon data_con
742       = text "ldfld" <+> sep [text "!" <> integer reduced_fld_no,
743                               ilxTypeR alt_env scrut_rep_ty <> text "::fld" <> integer reduced_fld_no]
744       | otherwise 
745       = text "lddata" <+> sep [ilxTypeR alt_env scrut_rep_ty <> comma, 
746                                ilxConRef env data_con <> comma,
747                                integer reduced_fld_no]
748
749
750 -------------------------
751
752 ilxBestTermArity = 3
753 ilxBestTypeArity = 7
754
755
756 -- Constants of unlifted types are represented as
757 -- applications to no arguments.
758 ilxFunApp env fun [] _ | isUnLiftedType (idType fun)
759   = pushId env fun
760
761 ilxFunApp env fun args tail_call 
762   =     -- For example:
763         --      ldloc f         function of type forall a. a->a
764         --      ldloc x         arg of type Int
765         --      .tail callfunc <Int32> (!0) --> !0
766         --
767     vcat [pushId env fun,ilxFunAppAfterPush env fun args tail_call]
768
769 ilxFunAppAfterPush env fun args tail_call 
770   =     -- For example:
771         --      ldloc f         function of type forall a. a->a
772         --      ldloc x         arg of type Int
773         --      .tail callfunc <Int32> (!0) --> !0
774         --
775     vcat [ilxFunAppArgs env 0 (idIlxRepType fun) args tail_call known_clo]
776   where
777     known_clo :: KnownClosure
778     known_clo =
779       case lookupIlxBindEnv env fun of
780           Just (_, StgRhsClosure  _ _ _ Updatable _ _)   -> Nothing 
781           Just (place, StgRhsClosure  _ _ fvs _ args _)  -> Just (place,fun,args,fvs)
782           _ -> Nothing -- trace (show fun ++ " --> " ++ show (idArity fun))
783
784 type KnownClosure = Maybe (  IlxEnv     -- Of the binding site of the function
785                            , Id         -- The function
786                            , [Var]      -- Binders
787                            , [Var])     -- Free vars of the closure
788
789 -- Push as many arguments as ILX allows us to in one go, and call the function
790 -- Recurse until we're done.
791 -- The function is already on the stack
792 ilxFunAppArgs :: IlxEnv
793               -> Int            -- Number of args already pushed (zero is a special case;
794                                 --      otherwise used only for place generation)
795               -> Type           -- Type of the function
796               -> [StgArg]       -- The arguments
797               -> Bool           -- True <=> tail call please
798               -> KnownClosure   -- Information about the function we're calling
799               -> SDoc
800
801 ilxFunAppArgs env num_sofar funty args tail_call known_clo
802  =   vcat [vcat (ilxMapPlaceArgs num_sofar pushArgWithVoids env now_args),
803            call_instr <+> (if num_sofar == 0 then text "() /* first step in every Haskell app. is to a thunk */ " else empty)
804                      <+> now_args_text
805                      <+> text "-->" 
806                      <+> later_ty_text,
807            later
808           ]
809   where
810     now_args_text = 
811       case now_arg_tys of
812         [] -> empty
813         _ -> hsep (map (pprIlxArgInfo env_after_now_tyvs) now_arg_tys)
814
815     later_ty_text
816         | isVoidIlxRepType later_ty = text "void"
817         | otherwise = ilxTypeR env_after_now_tyvs later_ty
818
819     (now_args,now_arg_tys,env_after_now_tyvs,later_args,later_ty) = 
820         case args of
821           (StgTypeArg v:rest) -> get_type_args ilxBestTypeArity args env funty
822           _ -> get_term_args 0 ilxBestTermArity args env funty
823
824      -- Only apply up to maxArity real (non-type) arguments
825      -- at a time.  ILX should, in principle, allow us to apply
826      -- arbitrary numbers, but you will get more succinct 
827      -- (and perhaps more efficient) IL code
828      -- if you apply in clumps according to its maxArity setting.
829      -- This is because it has to unwind the stack and store it away
830      -- in local variables to do the partial applications.
831      --
832      -- Similarly, ILX only allows one type application at a time, at
833      -- least until we implement unwinding the stack for this case.
834      --
835      -- NB: In the future we may have to be more careful 
836      -- all the way through 
837      -- this file to bind type variables as we move through
838      -- type abstractions and "forall" types.  This would apply
839      -- especially if the type variables were ever bound by expressions
840      -- involving the type variables.  
841
842     -- This part strips off at most "max" term applications or one type application
843     get_type_args 0 args env funty = ([],[],env,args,funty)
844     get_type_args max args env (NoteTy _ ty) = 
845           trace "IlxGen Internal Error: non representation type passed to get_args" (get_type_args max args env ty)
846     get_type_args max ((arg@(StgTypeArg v)):rest) env (ForAllTy tv rem_funty) 
847         = if isIlxTyVar tv then 
848             let env2 = extendIlxEnvWithFormalTyVars env [tv] in 
849             let rest_ty = deepIlxRepType (substTyWith [tv] [v] rem_funty) in 
850             let (now,now_tys,env3,later,later_ty) = get_type_args (max - 1) rest env rest_ty in 
851             let arg_ty = mkTyVarTy tv in 
852             (arg:now,(arg,arg_ty):now_tys,env2, later, later_ty)
853           else 
854              get_type_args max rest env rem_funty  -- ? subst??
855     get_type_args _ (StgTypeArg _:_) _ _ = trace "IlxGen Internal Error: get_type_args could not get ForAllTy for corresponding arg" ([],[],env,[],funty)
856     get_type_args _ args env funty = ([],[],env,args,funty)
857
858     get_term_args n max args env (NoteTy _ ty)
859        -- Skip NoteTy types 
860        = trace "IlxGen Internal Error: non representation type passed to get_term_args" (get_term_args n max args env ty)
861     get_term_args n 0 args env funty
862        -- Stop if we've hit the maximum number of ILX arguments to apply n one hit.
863        = ([],[],env,args,funty)
864     get_term_args n max args env funty
865       | (case known_clo of
866            Just (_,_,needed,_) -> needed `lengthIs` n
867            Nothing -> False)
868        -- Stop if we have the optimal number for a direct call
869        = ([],[],env,args,funty)
870     get_term_args _ _ (args@(StgTypeArg _:_)) env funty 
871        -- Stop if we hit a type arg.
872        = ([],[],env,args,funty)
873     get_term_args n max (h:t) env (FunTy dom ran)
874        -- Take an argument.
875        = let (now,now_tys,env2,later,later_ty) = get_term_args (n+1) (max - 1) t env ran in 
876          (h:now, (h,dom):now_tys,env2,later,later_ty)
877     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)
878     get_term_args _ max args env funty = ([],[],env,args,funty)
879
880     -- Are there any remaining arguments?
881     done  = case later_args of
882           [] -> True
883           _ -> False
884
885     -- If so, generate the subsequent calls.
886     later = if done then text "// done"  
887             else ilxFunAppArgs env (num_sofar + length now_args) later_ty later_args tail_call Nothing
888
889     -- Work out whether to issue a direct call a known closure (callclo) or
890     -- an indirect call (callfunc).  Basically, see if the identifier has
891     -- been let-bound, and then check we are applying exactly the right 
892     -- number of arguments.  Also check that it's not a thunk (actually, this
893     -- is done up above).
894     -- 
895     -- The nasty "all" check makes sure that 
896     -- the set of type variables in scope at the callsite is a superset 
897     -- of the set of type variables needed for the direct call.  This is
898     -- is needed because not all of the type variables captured by a 
899     -- let-bound binding will get propogated down to the callsite, and 
900     -- the ILX system of polymorphism demands that the free type variables
901     -- get reapplied when we issue the direct "callclo".  The
902     -- type variables are in reality also "bound up" in the closure that is
903     -- passed as the first argument, so when we do an indirect call
904     -- to that closure we're fine, which is why we don't need them in 
905     -- the "callfunc" case.
906     basic_call_instr =
907       case known_clo of
908         Just (known_env,fun,needed,fvs) | (equalLength needed now_args) && 
909                                           all (\x -> elemIlxTyEnv x env) free_ilx_tvs -> 
910            vcat [text "callclo class",
911                  nameReference env (idName fun) <+> singleQuotes (ilxEnvQualifyByModule env (ppr fun)),
912                  pprTypeArgs ilxTypeR env (map mkTyVarTy free_ilx_tvs)]
913            <> text ","
914           where 
915            (free_ilx_tvs, free_non_ilx_tvs,free_vs) = categorizeVars fvs
916         otherwise -> text "callfunc"
917     call_instr =
918            if (tail_call && done) then text "tail." <+> basic_call_instr
919            else basic_call_instr
920
921
922 --------------------------
923 -- Print the arg info at the call site
924 -- For type args we are, at the moment, required to
925 -- give both the actual and the formal (bound).  The formal
926 -- bound is always System.Object at the moment (bounds are
927 -- not properly implemented in ILXASM in any case, and nor do
928 -- we plan on making use og them) For
929 -- non-type args the actuals are on the stack, and we just give the
930 -- formal type.
931 pprIlxArgInfo env (StgTypeArg  arg,ty) =  
932     angleBrackets (ilxTypeR env (deepIlxRepType arg) <+> ilxComment (text "actual for tyvar")) <+> text "<class [mscorlib] System.Object>" 
933 pprIlxArgInfo env (_,ty) =  
934     parens (ilxTypeL env ty)
935
936
937 ----------------------------
938 -- Code for a binding
939 ilxBind :: IlxEEnv -> StgBinding -> SDoc
940 ilxBind eenv@(IlxEEnv env _) bind = 
941     vcat [vcat (map (ilxRhs env rec) pairs), 
942           vcat (map (ilxFixupRec env rec) pairs)]
943        where 
944          rec = ilxRecIds1 bind
945          pairs = ilxPairs1 bind
946
947
948 ----------------------------
949 -- Allocate a closure or constructor.  Fix up recursive definitions.
950 ilxRhs :: IlxEnv -> [Id] -> (Id, StgRhs) -> SDoc
951
952 ilxRhs env rec (bndr, _) | isVoidIlxRepId bndr  
953   = empty
954
955 ilxRhs env rec (bndr, StgRhsCon _ con args)
956   = vcat [text " /* ilxRhs:StgRhsCon */ " <+> ilxConApp env con args,
957            text "stloc" <+> pprId bndr
958           ]
959
960 ilxRhs env rec (bndr, StgRhsClosure _ _ fvs upd args rhs)
961   =     -- Assume .closure v<any A>(int64,!A) { 
962         --              .apply <any B> (int32) (B) { ... }
963         --         }
964         -- Then
965         --    let v = \B (x:int32) (y:B). ... 
966         -- becomes:
967         --    newclo v<int32>(int64,!0)
968         --    stloc v
969     vcat [vcat (map pushFv free_vs),
970           (if null free_non_ilx_tvs then empty else (ilxComment (text "ignored some higher order type arguments in application - code will be non-verifiable"))),
971           text "newclo" <+> clotext,
972           text "stloc" <+> pprId bndr
973     ]
974   where
975     pushFv id = if elem id rec then text "ldnull" else pushId env id
976     (free_ilx_tvs, free_non_ilx_tvs,free_vs) = categorizeVars fvs
977     clotext = pprIlxNamedTyConApp env (ilxEnvQualifyByModule env (ppr bndr)) (map mkTyVarTy free_ilx_tvs)
978
979 ilxFixupRec env rec (bndr, _) | isVoidIlxRepId bndr = ilxComment (text "no recursive fixup for void-rep-id")
980
981 ilxFixupRec env rec (bndr, StgRhsCon _ con args)
982   = text "// no recursive fixup"
983
984 ilxFixupRec env rec (bndr, StgRhsClosure _ _ fvs upd args rhs)
985      = vcat [vcat (map fixFv rec)]
986   where
987     fixFv recid = if elem recid fvs then 
988                     vcat [pushId env bndr,
989                           pushId env recid,
990                           text "stclofld" <+> clotext <> text "," <+> pprId recid] 
991                 else text "//no fixup needed for" <+> pprId recid
992     (free_ilx_tvs, free_non_ilx_tvs,free_vs) = categorizeVars fvs
993     clotext = pprIlxNamedTyConApp env (ilxEnvQualifyByModule env (ppr bndr)) (map mkTyVarTy free_ilx_tvs)
994
995
996
997 ---------------------------------------------
998 -- Code for a top-level binding in a module
999 ilxPairs binds = concat (map ilxPairs1 binds)
1000
1001 ilxPairs1 (StgNonRec _ bndr rhs) = [(bndr,rhs)]
1002 ilxPairs1 (StgRec _ pairs)       = pairs
1003
1004 ilxRecIds1 (StgNonRec _ bndr rhs) = []
1005 ilxRecIds1 (StgRec _ pairs)       = map fst pairs
1006
1007 ---------------------------------------------
1008 -- Code for a top-level binding in a module
1009 -- TODO: fix up recursions amongst CAF's
1010 -- e.g. 
1011 --    x = S x
1012 -- for infinity...
1013 -- 
1014 -- For the moment I've put in a completely spurious "reverse"...
1015 --
1016 -- Consider: make fixing up of CAF's part of ILX?  i.e.
1017 -- put static, constant, allocated datastructures into ILX. 
1018
1019 stableSortBy :: (a -> a -> Ordering) -> [a] -> [a]
1020 stableSortBy f (h:t) = insertBy f h (stableSortBy f t)
1021 stableSortBy f [] = []
1022
1023 usedBy :: (Id,StgRhs) -> (Id,StgRhs) -> Ordering
1024 usedBy (m,_) (_,StgRhsCon _ data_con args) | any (isArg m) args = LT
1025 usedBy (m,_) (n,_) | m == n = EQ
1026 usedBy (m,_) (_,_) = GT
1027
1028 isArg m  (StgVarArg n) = (n == m)
1029 isArg m _ = False
1030
1031
1032 ilxTopBind :: Module -> IlxEnv -> [(Id,StgRhs)] -> SDoc
1033 --ilxTopBind mod env (StgNonRec _ bndr rhs) = 
1034 --ilxTopRhs env (bndr,rhs)
1035 ilxTopBind mod env pairs       = 
1036    vcat [text ".class" <+> pprId mod,
1037          nest 2 (braces (nest 2 (vcat [empty,cctor, flds, empty])))]
1038      where
1039        cctor = vcat [text ".method static rtspecialname specialname void .cctor()",
1040                      nest 2 (braces 
1041                       (nest 2 (vcat [text ".maxstack 100",
1042                                      text "ldstr \"LOG: initializing module" <+> pprId mod <+> text "\" call void ['mscorlib']System.Console::WriteLine(class [mscorlib]System.String)",
1043                                      vcat (map (ilxTopRhs mod env) (stableSortBy usedBy pairs)), 
1044                                      text "ldstr \"LOG: initialized module" <+> pprId mod <+> text "\" call void ['mscorlib']System.Console::WriteLine(class [mscorlib]System.String)",
1045                                      text "ret",
1046                                      empty])))]
1047        flds =   vcat (map (ilxTopRhsStorage mod env) pairs)
1048
1049 --ilxTopRhs mod env (bndr, _) | isVoidIlxRepId bndr 
1050 --  = empty
1051
1052 ilxTopRhs mod env (bndr, StgRhsClosure _ _ fvs upd args rhs)
1053   = vcat [vcat (map (pushId env) free_vs),
1054          (if null free_non_ilx_tvs then empty else (ilxComment (text "ignored some higher order type arguments in application - code will be non verifiable...."))),
1055           text "newclo" <+> pprIlxNamedTyConApp env (ilxEnvQualifyByModule env (ppr bndr)) (map mkTyVarTy free_ilx_tvs),
1056           text "stsfld"  <+> pprFieldRef env (mod,bndTy,bndr)
1057     ]
1058   where
1059     (free_ilx_tvs, free_non_ilx_tvs,free_vs) = categorizeVars fvs
1060     bndTy = idIlxRepType bndr
1061
1062 ilxTopRhs mod env (bndr, StgRhsCon _ data_con args)
1063   = vcat [ text " /* ilxTopRhs: StgRhsCon */ " <+> ilxConApp env data_con args, 
1064            text "stsfld" <+> pprFieldRef env (mod,bndTy,bndr)
1065     ]
1066   where
1067     bndTy = idIlxRepType bndr
1068
1069 pprFieldRef env (mod,ty,id) 
1070   =  ilxTypeL env ty <+> moduleReference env mod <+> pprId mod <> text "::" <> pprId id
1071
1072 ilxTopRhsStorage mod env (bndr, StgRhsClosure _ _ _ _ _ _) 
1073   =   text ".field public static " <+> ilxTypeL env bndTy <+> pprId bndr
1074   where
1075     bndTy = idIlxRepType bndr
1076 ilxTopRhsStorage mod env (bndr, StgRhsCon _ _ _) 
1077   =   text ".field public static " <+> ilxTypeL env bndTy <+> pprId bndr
1078   where
1079     bndTy = idIlxRepType bndr
1080
1081 --------------------------------------
1082 -- Push an argument
1083 pushArgWithVoids =  pushArg_aux True
1084 pushArg = pushArg_aux False
1085
1086 pushArg_aux voids env (StgTypeArg ty) = empty
1087 pushArg_aux voids env (StgVarArg var) = pushId_aux voids env var
1088 pushArg_aux voids env (StgLitArg lit) = pushLit env lit
1089
1090
1091 mapi f l = mapi_aux f l 0
1092
1093 mapi_aux f [] n = []
1094 mapi_aux f (h:t) n = f n h : mapi_aux f t (n+1)
1095
1096 --------------------------------------
1097 -- Push an Id
1098 pushId = pushId_aux False
1099
1100 pushId_aux :: Bool -> IlxEnv -> Id -> SDoc
1101 pushId_aux voids _ id | isVoidIlxRepId id =
1102    /* if voids then  text "ldunit" else */ ilxComment (text "pushId: void rep skipped")
1103 pushId_aux _ env var 
1104   = case lookupIlxVarEnv env var of
1105           Just Arg    -> text "ldarg"    <+> pprId var
1106           Just (CloVar n) -> text "ldenv" <+> int n
1107           Just Local  -> text "ldloc"    <+> pprId var
1108           Just (Top m)  -> 
1109              vcat [ilxComment (text "pushId (Top) " <+> pprId m), 
1110                    text "ldsfld" <+> ilxTypeL env (idIlxRepType var)
1111                       <+> moduleReference env m <+> pprId (moduleName m) <> text "::" <> pprId var]
1112
1113           Nothing ->  
1114              vcat [ilxComment (text "pushId (import) " <+> pprIlxTopVar env var), 
1115                    text "ldsfld" <+> ilxTypeL env (idIlxRepType var) 
1116                     <+> pprIlxTopVar env var]
1117
1118 --------------------------------------
1119 -- Push a literal
1120 pushLit env (MachChar c)   = text "ldc.i4" <+> int c
1121 pushLit env (MachStr s)    = text "ldsflda char "  <+> ilxEnvQualifyByExact env (text "string") -- pprFSInILStyle s 
1122 pushLit env (MachInt i)    = text "ldc.i4" <+> integer i
1123 pushLit env (MachInt64 i)  = text "ldc.i8" <+> integer i
1124 pushLit env (MachWord w)   = text "ldc.i4" <+> integer w <+> text "conv.u4"
1125 pushLit env (MachWord64 w) = text "ldc.i8" <+> integer w <+> text "conv.u8"
1126 pushLit env (MachFloat f)  = text "ldc.r4" <+> rational f
1127 pushLit env (MachDouble f) = text "ldc.r8" <+> rational f
1128 pushLit env (MachNullAddr)  = text "ldc.i4 0"
1129 pushLit env (MachLabel l _) = trace "WARNING: Cannot compile MachLabel to ILX in IlxGen.lhs" (text "// MachLabel!!!  Not valid in ILX!!")
1130
1131 pprIlxTopVar env v
1132   | isExternalName n = (nameReference env n) <> pprId (nameModule n) <> text "::" <> singleQuotes (ppr (nameModule n) <> text "_" <> ppr (nameOccName n))
1133   | otherwise      = pprId (nameOccName n)
1134   where
1135     n = idName v
1136
1137 \end{code}
1138
1139
1140 %************************************************************************
1141 %*                                                                      *
1142 \subsection{Printing types}
1143 %*                                                                      *
1144 %************************************************************************
1145
1146
1147 \begin{code}
1148
1149 isVoidIlxRepType (NoteTy   _ ty) = isVoidIlxRepType ty
1150 isVoidIlxRepType (TyConApp tc _) | (tyConPrimRep tc == VoidRep) = True
1151 isVoidIlxRepType (TyConApp tc tys) 
1152   = isUnboxedTupleTyCon tc && null (filter (not. isVoidIlxRepType) tys)
1153 isVoidIlxRepType _ = False
1154
1155 isVoidIlxRepId id = isVoidIlxRepType (idType id)
1156
1157
1158
1159 -- Get rid of all NoteTy and NewTy artifacts
1160 deepIlxRepType :: Type -> Type
1161 deepIlxRepType (FunTy l r)
1162   = FunTy (deepIlxRepType l) (deepIlxRepType r)
1163
1164 deepIlxRepType ty@(TyConApp tc tys) 
1165   =        -- collapse UnboxedTupleTyCon down when it contains VoidRep types.
1166            -- e.g.      (# State#, Int#, Int# #)  ===>   (# Int#, Int# #)
1167             if isUnboxedTupleTyCon tc then 
1168                let tys' = map deepIlxRepType (filter (not. isVoidIlxRepType) tys) in 
1169                case tys' of
1170                   [h] -> h
1171                   _ -> mkTupleTy Unboxed (length tys') tys'
1172             else 
1173               TyConApp tc (map deepIlxRepType tys)
1174 deepIlxRepType (AppTy f x)     = AppTy (deepIlxRepType f) (deepIlxRepType x)
1175 deepIlxRepType (ForAllTy b ty) = ForAllTy b (deepIlxRepType ty)
1176 deepIlxRepType (NoteTy   _ ty) = deepIlxRepType ty
1177 deepIlxRepType (PredTy p)      = deepIlxRepType (predTypeRep p)
1178 deepIlxRepType ty@(TyVarTy tv) = ty
1179
1180 idIlxRepType id = deepIlxRepType (idType id)
1181
1182 --------------------------
1183 -- Some primitive type constructors are not thunkable.
1184 -- Everything else needs to be marked thunkable.
1185 ilxTypeL :: IlxEnv -> Type -> SDoc
1186
1187 ilxTypeL env ty | isUnLiftedType ty ||  isVoidIlxRepType ty = ilxTypeR env ty
1188 ilxTypeL env ty = text "thunk" <> angleBrackets (ilxTypeR env ty)
1189
1190
1191 --------------------------
1192 -- Print non-thunkable version of type.
1193 --
1194
1195 ilxTypeR :: IlxEnv -> Type -> SDoc
1196 ilxTypeR env ty | isVoidIlxRepType ty = text "/* unit skipped */"
1197 ilxTypeR env ty@(AppTy f _) | isTyVarTy f    = ilxComment (text "type app:" <+> pprType ty) <+> (text "class [mscorlib]System.Object")
1198 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))
1199 ilxTypeR env (TyVarTy tv)       = ilxTyVar env tv
1200
1201 -- The following is a special rule for types constructed out of 
1202 -- higher kinds, e.g. Monad f or Functor f.  
1203 --
1204 -- The code below is not as general as it should be, but as I
1205 -- have no idea if this approach will even work, I'm going to
1206 -- just try it out on some simple cases arising from the prelude.
1207 ilxTypeR env ty@(TyConApp tc (h:t)) | isAlgTyCon tc && null (tyConTyVars tc)
1208    = ilxComment (text "what on earth? 2") <+> (ilxTypeR env (TyConApp tc t))
1209 ilxTypeR env ty@(TyConApp tc (h:t)) | isAlgTyCon tc && not (isIlxTyVar (hd (tyConTyVars tc)))
1210    = ilxTypeR env (TyConApp tc t)
1211 ilxTypeR env (TyConApp tc args) = ilxTyConApp env tc args
1212
1213   -- nb. the only legitimate place for VoidIlxRepTypes to occur in normalized IlxRepTypes 
1214   -- is on the left of an arrow
1215   --  We could probably eliminate all but a final occurrence of these.
1216 ilxTypeR env (FunTy arg res)| isVoidIlxRepType res 
1217     = pprIlxFunTy (ilxTypeL env arg) (text "void")
1218 ilxTypeR env (FunTy arg res)
1219     = pprIlxFunTy (ilxTypeL env arg) (ilxTypeR env res)
1220
1221 ilxTypeR env ty@(ForAllTy tv body_ty) | isIlxTyVar tv
1222   = parens (text "forall" <+> pprTyVarBinders env' [tv] <+> nest 2 (ilxTypeR env' body_ty))
1223     where
1224        env' = extendIlxEnvWithFormalTyVars env [tv]
1225
1226 ilxTypeR env ty@(ForAllTy tv body_ty) | otherwise
1227   = ilxComment (text "higher order type var " <+> pprId tv) <+>
1228     pprIlxFunTy (text "class [mscorlib]System.Object") (ilxTypeR env body_ty)
1229
1230 ilxTypeR env (NoteTy _ ty)       
1231    = trace "WARNING! non-representation type given to ilxTypeR: see generated ILX for context where this occurs"
1232      (vcat [text "/* WARNING! non-representation type given to ilxTypeR! */",
1233            ilxTypeR env ty ])
1234
1235 pprIlxFunTy dom ran = parens (hsep [text "func",parens dom,text "-->", ran])
1236
1237 ilxTyConApp env tcon args =
1238    case lookupUFM tyPrimConTable (getUnique tcon) of
1239         Just f  -> f args env
1240         Nothing -> 
1241             (if isUnboxedTupleTyCon tcon then pprIlxUnboxedTupleTyConApp else pprIlxBoxedTyConApp)
1242               env tcon args
1243
1244 pprIlxTyCon env tcon = nameReference env (getName tcon) <> ppr tcon
1245 pprIlxUnboxedTupleTyConApp env tcon args 
1246   = text "/* unboxed */ value class" <+> pprIlxTyCon env tcon' <> pprTypeArgs ilxTypeL env non_void
1247   where 
1248    non_void = filter (not . isVoidIlxRepType) args
1249    tcon' = dataConTyCon (tupleCon Unboxed (length non_void)) 
1250 pprIlxBoxedTyConApp env tcon args 
1251   = pprIlxNamedTyConApp env (pprIlxTyCon env tcon) args
1252 pprIlxNamedTyConApp env tcon_text args 
1253   = text "class" <+> tcon_text <> pprTypeArgs ilxTypeR env args
1254
1255 -- Returns e.g: <Int32, Bool>
1256 -- Void-sized type arguments are _always_ eliminated, everywhere.
1257 -- If the type constructor is an unboxed tuple type then it should already have
1258 -- been adjusted to be the correct constructor.
1259 pprTypeArgs f env tys = pprTypeArgs_aux f env (filter (not . isVoidIlxRepType) tys)
1260
1261 pprTypeArgs_aux f env []  = empty
1262 pprTypeArgs_aux f env tys = angleBrackets (pprSepWithCommas (f env) tys)
1263
1264
1265 pprTyVarBinders :: IlxEnv -> [TyVar] -> SDoc
1266 -- Returns e.g: <class [mscorlib]System.Object> <class [mscorlib]System.Object>
1267 -- plus a new environment with the type variables added.
1268 pprTyVarBinders env [] = empty
1269 pprTyVarBinders env tvs = angleBrackets (pprSepWithCommas (pprTyVarBinder_aux env) tvs)
1270
1271 pprTyVarBinder :: IlxEnv -> TyVar -> SDoc
1272 pprTyVarBinder env tv = 
1273     if isIlxTyVar tv then 
1274        angleBrackets (pprTyVarBinder_aux env tv)
1275     else
1276        ilxComment (text "higher order tyvar" <+> pprId tv <+> 
1277                          text ":" <+> ilxTypeR env (tyVarKind tv)) <+>
1278              ilxComment (text "omitted")
1279              -- parens (text "class [mscorlib]System.Object" <+> pprId tv)
1280
1281
1282 pprTyVarBinder_aux env tv = 
1283    ilxComment (text "tyvar" <+> pprId tv <+> text ":" <+> 
1284                         ilxTypeR env (tyVarKind tv)) <+>
1285              (text "class [mscorlib]System.Object")
1286
1287 -- Only a subset of Haskell types can be generalized using the type quantification
1288 -- of ILX
1289 isIlxForAllKind h = 
1290         ( h `eqKind` liftedTypeKind) ||
1291         ( h `eqKind` unliftedTypeKind) ||
1292         ( h `eqKind` openTypeKind)
1293
1294 isIlxTyVar v = isTyVar v && isIlxForAllKind (tyVarKind v)
1295
1296 categorizeVars fvs = (ilx_tvs, non_ilx_tvs, vs)
1297          where
1298            (tvs, vs) = partition isTyVar fvs
1299            (ilx_tvs, non_ilx_tvs) = categorizeTyVars tvs
1300
1301 categorizeTyVars tyvs = partition isIlxTyVar tyvs
1302
1303 pprValArgTys ppr_ty env tys = parens (pprSepWithCommas (ppr_ty env) tys)
1304
1305 pprId id = singleQuotes (ppr id)
1306
1307 \end{code}                      
1308
1309 %************************************************************************
1310 %*                                                                      *
1311 \subsection{IlxEnv}     
1312 %*                                                                      *
1313 %************************************************************************
1314
1315 \begin{code}
1316 type IlxTyEnv = [TyVar]
1317 emptyIlxTyEnv = []
1318
1319 -- Nb. There is currently no distinction between the kinds of type variables.
1320 -- We may need to add this to print out correct numbers, esp. for
1321 -- "forall" types
1322 extendIlxTyEnvWithFreeTyVars env tyvars = env ++ mkIlxTyEnv tyvars -- bound by .closure x<...> in a closure declared with type parameters
1323 extendIlxTyEnvWithFormalTyVars env tyvars = env ++ mkIlxTyEnv tyvars -- bound by "forall <...>" in a type
1324 extendIlxTyEnvWithTyArgs env tyvars = env ++ mkIlxTyEnv tyvars -- bound by "<...>" in a closure implementing a universal type
1325
1326 formalIlxTyEnv tyvars = mkIlxTyEnv tyvars
1327 mkIlxTyEnv tyvars = [ v | v <- tyvars, isIlxTyVar v ]
1328
1329 data HowBound = Top Module      -- Bound in a modules
1330               | Arg     -- Arguments to the enclosing closure
1331               | CloVar Int -- A free variable of the enclosing closure
1332                            -- The int is the index of the field in the 
1333                            -- environment
1334               | Local   -- Local let binding
1335
1336 -- The SDoc prints a unique name for the syntactic block we're currently processing,
1337 -- e.g. Foo_bar_baz when inside closure baz inside closure bar inside module Foo.
1338 data IlxEnv = IlxEnv (Module, IlxTyEnv, IdEnv HowBound,IdEnv (IlxEnv, StgRhs), Place,Bool)
1339 type Place = (SDoc,SDoc)
1340
1341 ilxTyVar  env tv
1342   = go 0 (ilxEnvTyEnv env)
1343   where
1344     go n []                 
1345       = pprTrace "ilxTyVar" (pprId tv <+> text "tv_env = { "
1346            <+> pprSepWithCommas
1347                  (\x -> pprId x <+> text ":" <+> ilxTypeR env (tyVarKind x)) 
1348                (ilxEnvTyEnv env) <+> text "}") 
1349         (char '!' <> pprId tv) 
1350     go n (x:xs)
1351       = {- pprTrace "go" (ppr (tyVarName tv) <+> ppr (tyVarName x)) -}
1352         (if tyVarName x== tyVarName tv then  char '!' <> int n <+> ilxComment (char '!' <> pprId tv) 
1353          else go (n+1) xs)
1354
1355 emptyIlxEnv :: Bool -> Module -> IlxEnv
1356 emptyIlxEnv trace mod = IlxEnv (mod, emptyIlxTyEnv, emptyVarEnv, emptyVarEnv, (ppr mod,empty),trace)
1357
1358 nextPlace place sdoc = place <> sdoc
1359 usePlace  place sdoc = place <> sdoc
1360
1361 ilxEnvModule (IlxEnv (m, _, _,  _, _,_)) = m
1362 ilxEnvSetPlace (IlxEnv (m, tv_env, id_env,  bind_env, (mod,exact),tr)) sdoc 
1363    = IlxEnv (m, tv_env, id_env,  bind_env, (mod, sdoc),tr)
1364 ilxEnvNextPlace (IlxEnv (m, tv_env, id_env,  bind_env, (mod,exact),tr)) sdoc 
1365    = IlxEnv (m, tv_env, id_env,  bind_env, (mod, nextPlace exact sdoc),tr)
1366 ilxEnvQualifyByModule (IlxEnv (_, _, _, _,(mod,_),_)) sdoc = usePlace mod sdoc
1367 ilxEnvQualifyByExact (IlxEnv (_, _, _, _,(mod,exact),_)) sdoc = usePlace mod sdoc <> usePlace exact sdoc
1368
1369 ilxPlaceStgBindDefault env = ilxEnvNextPlace env (text "D")
1370 ilxPlaceStgRhsClosure env bndr = ilxEnvSetPlace env (ppr bndr) -- binders are already unique
1371 ilxPlaceStgCaseScrut env = ilxEnvNextPlace env (text "S")
1372
1373 ilxPlaceAlt :: IlxEnv -> Int -> IlxEnv
1374 ilxPlaceAlt env i = ilxEnvNextPlace env (text "a" <> int i)
1375 ilxPlacePrimAltLit env i = ilxEnvNextPlace env (text "P" <> int i)
1376 ilxMapPlaceArgs start f env args = [ f (ilxEnvNextPlace env (text "A" <> int i)) a | (i,a) <- [start..] `zip` args ]
1377 ilxMapPlaceAlts f env alts = [ f (ilxPlaceAlt env i) alt | (i,alt) <- [1..] `zip` alts ]
1378
1379 extendIlxEnvWithFreeTyVars (IlxEnv (mod, tv_env, id_env,  bind_env, place,tr)) tyvars 
1380   = IlxEnv (mod, extendIlxTyEnvWithFreeTyVars tv_env tyvars,id_env,  bind_env, place,tr)
1381
1382 extendIlxEnvWithFormalTyVars (IlxEnv (mod, tv_env, id_env,  bind_env, place,tr)) tyvars 
1383   = IlxEnv (mod, extendIlxTyEnvWithFormalTyVars tv_env tyvars,id_env,  bind_env, place,tr)
1384
1385 extendIlxEnvWithTyArgs (IlxEnv (mod, tv_env, id_env,  bind_env, place,tr)) tyvars 
1386   = IlxEnv (mod, extendIlxTyEnvWithTyArgs tv_env tyvars,id_env,  bind_env, place,tr)
1387
1388 extendIlxEnvWithArgs :: IlxEnv -> [Var] -> IlxEnv
1389 extendIlxEnvWithArgs (IlxEnv (mod, tv_env, id_env,  bind_env, place,tr)) args
1390   = IlxEnv (mod, extendIlxTyEnvWithTyArgs tv_env [tv      | tv <- args, isIlxTyVar tv],
1391             extendVarEnvList id_env [(v,Arg) | v  <- args, not (isIlxTyVar v)], 
1392              bind_env, place,tr)
1393
1394 extendIlxEnvWithFreeVars (IlxEnv (mod, tv_env, id_env,  bind_env, place,tr)) args
1395   = IlxEnv (mod, 
1396             extendIlxTyEnvWithFreeTyVars tv_env [tv | tv <- args, isIlxTyVar tv],
1397             extendVarEnvList id_env (clovs 0 args), 
1398             bind_env, 
1399             place,tr)
1400    where
1401      clovs _ [] = []
1402      clovs n (x:xs) = if not (isIlxTyVar x) then (x,CloVar n):clovs (n+1) xs else clovs n xs
1403
1404 extendIlxEnvWithBinds env@(IlxEnv (mod, tv_env, id_env, bind_env, place,tr)) bnds
1405   = IlxEnv (mod, tv_env, id_env, 
1406             extendVarEnvList bind_env [(v,(env,rhs)) | (v,rhs) <- bnds], 
1407             place,tr)
1408
1409 extendIlxEnvWithLocals (IlxEnv (m, tv_env, id_env, bind_env, p,tr)) locals
1410   = IlxEnv (m, tv_env, 
1411             extendVarEnvList id_env [(v,Local) | (LocalId v,_) <- locals],
1412             extendVarEnvList bind_env [(v,(env,rhs)) | (LocalId v,Just (env,rhs)) <- locals], 
1413             p,tr)
1414 extendIlxEnvWithTops env@(IlxEnv (m, tv_env, id_env, bind_env, place,tr)) mod binds
1415   = IlxEnv (m, tv_env, 
1416             extendVarEnvList id_env [(bndr,Top mod) | (bndr,rhs) <- binds], 
1417             extendVarEnvList bind_env [(bndr,(env, rhs)) | (bndr,rhs) <- binds], 
1418             place,tr)
1419
1420 formalIlxEnv (IlxEnv (m, tv_env, id_env, bind_env, place, tr)) tyvars 
1421   = IlxEnv (m, formalIlxTyEnv tyvars, id_env, bind_env, place, tr)
1422
1423 ilxEnvTyEnv :: IlxEnv -> IlxTyEnv
1424 ilxEnvTyEnv (IlxEnv (_, tv_env, _,_,_,_)) = tv_env 
1425 elemIlxTyEnv var env = elem var (ilxEnvTyEnv env )
1426 elemIlxVarEnv var (IlxEnv (_, _, id_env,_,_,_)) = elemVarEnv var id_env 
1427 lookupIlxVarEnv (IlxEnv (_, _, id_env,_,_,_)) var = lookupVarEnv id_env var
1428 lookupIlxBindEnv (IlxEnv (_, _, _, bind_env,_,_)) var = lookupVarEnv bind_env var
1429
1430 \end{code}
1431
1432
1433 \begin{code}
1434 type IlxLabel = SDoc
1435
1436 pprIlxLabel lbl = lbl
1437
1438 mkJoinLabel :: Id -> IlxLabel
1439 mkJoinLabel v = text "J_" <> ppr v
1440
1441 mkAltLabel  :: Id -> Int -> IlxLabel
1442 mkAltLabel v n = text "A" <> int n <> ppr v
1443
1444 ilxLabel :: IlxLabel -> SDoc
1445 ilxLabel lbl =  line $$ (pprIlxLabel lbl <> colon)
1446 \end{code}
1447
1448
1449 %************************************************************************
1450 %*                                                                      *
1451 \subsection{Local pretty helper functions}
1452 %*                                                                      *
1453 %************************************************************************
1454
1455 \begin{code}
1456 pprSepWithCommas :: (a -> SDoc) -> [a] -> SDoc
1457 pprSepWithCommas pp xs = sep (punctuate comma (map pp xs))
1458 ilxComment pp   = text "/*" <+> pp <+> text "*/"
1459 singleQuotes pp = char '\'' <> pp <> char '\''
1460
1461 line = text "// ----------------------------------"
1462
1463 hscOptionQual = text ".i_"
1464
1465 nameReference env n
1466   | isInternalName n = empty
1467   | ilxEnvModule env == nameModule n  = text ""
1468   | isHomeModule (nameModule n)   = moduleNameReference (moduleName (nameModule n))
1469 -- HACK: no Vanilla modules should be around, but they are!!  This
1470 -- gets things working for the scenario "standard library linked as one
1471 -- assembly with multiple modules + a one module program running on top of this"
1472 -- Same applies to all other mentions of Vailla modules in this file
1473   | isVanillaModule (nameModule n)  && not inPrelude =  basePackageReference
1474   | isVanillaModule (nameModule n)  && inPrelude =   moduleNameReference (moduleName (nameModule n))
1475 -- end hack
1476   | otherwise = packageReference (modulePackage (nameModule n))
1477
1478 packageReference p = brackets (singleQuotes (ppr p  <> hscOptionQual))
1479 moduleNameReference m = brackets ((text ".module") <+> (singleQuotes (pprModuleName m <> hscOptionQual <> text "o")))
1480
1481 moduleReference env m
1482   | ilxEnvModule env   == m = text ""
1483   | isHomeModule m = moduleNameReference (moduleName m)
1484   -- See hack above
1485   | isVanillaModule m && not inPrelude =  basePackageReference
1486   | isVanillaModule m && inPrelude =  moduleNameReference (moduleName m)
1487   -- end hack
1488   | otherwise  =  packageReference (modulePackage m)
1489
1490 basePackageReference = packageReference basePackage
1491 inPrelude = basePackage == opt_InPackage
1492
1493 ------------------------------------------------
1494 -- This code is copied from absCSyn/CString.lhs,
1495 -- and modified to do the correct thing!  It's
1496 -- still a mess though.  Also, still have to do the
1497 -- right thing for embedded nulls.
1498
1499 pprFSInILStyle :: FastString -> SDoc
1500 pprFSInILStyle fs = doubleQuotes (text (stringToC (unpackFS fs)))
1501
1502 stringToC   :: String -> String
1503 -- Convert a string to the form required by C in a C literal string
1504 -- Tthe hassle is what to do w/ strings like "ESC 0"...
1505 stringToC ""  = ""
1506 stringToC [c] = charToC c
1507 stringToC (c:cs)
1508     -- if we have something "octifiable" in "c", we'd better "octify"
1509     -- the rest of the string, too.
1510   = if (c < ' ' || c > '~')
1511     then (charToC c) ++ (concat (map char_to_C cs))
1512     else (charToC c) ++ (stringToC cs)
1513   where
1514     char_to_C c | c == '\n' = "\\n"     -- use C escapes when we can
1515                 | c == '\a' = "\\a"
1516                 | c == '\b' = "\\b"     -- ToDo: chk some of these...
1517                 | c == '\r' = "\\r"
1518                 | c == '\t' = "\\t"
1519                 | c == '\f' = "\\f"
1520                 | c == '\v' = "\\v"
1521                 | otherwise = '\\' : (trigraph (ord c))
1522
1523 charToC :: Char -> String
1524 -- Convert a character to the form reqd in a C character literal
1525 charToC c = if (c >= ' ' && c <= '~')   -- non-portable...
1526             then case c of
1527                   '\'' -> "\\'"
1528                   '\\' -> "\\\\"
1529                   '"'  -> "\\\""
1530                   '\n' -> "\\n"
1531                   '\a' -> "\\a"
1532                   '\b' -> "\\b"
1533                   '\r' -> "\\r"
1534                   '\t' -> "\\t"
1535                   '\f' -> "\\f"
1536                   '\v' -> "\\v"
1537                   _    -> [c]
1538             else '\\' : (trigraph (ord c))
1539
1540 trigraph :: Int -> String
1541 trigraph n
1542   = [chr ((n `div` 100) `rem` 10 + ord '0'),
1543      chr ((n `div` 10) `rem` 10 + ord '0'),
1544      chr (n `rem` 10 + ord '0')]
1545
1546
1547 \end{code}
1548
1549 %************************************************************************
1550 %*                                                                      *
1551 \subsection{PrimOps and Constructors}
1552 %*                                                                      *
1553 %************************************************************************
1554
1555 \begin{code}
1556 ----------------------------
1557 -- Allocate a fresh constructor
1558
1559 ilxConApp env data_con args
1560   | isUnboxedTupleCon data_con
1561      = let tm_args' = filter (not. isVoidIlxRepType . stgArgType) tm_args in 
1562        case tm_args' of
1563         [h] -> 
1564           -- Collapse the construction of an unboxed tuple type where
1565           -- every element is zero-sized
1566             vcat (ilxMapPlaceArgs 0 pushArg env tm_args')
1567         _ -> 
1568           -- Minimize the construction of an unboxed tuple type, which
1569           -- may contain zero-sized elements.  Recompute all the 
1570           -- bits and pieces from the simpler case below for the new data
1571           -- type constructor....
1572            let data_con' = tupleCon Unboxed (length tm_args') in 
1573            let rep_ty_args' = filter (not . isVoidIlxRepType) rep_ty_args in 
1574
1575            let tycon' = dataConTyCon data_con' in
1576            let (formal_tyvars', formal_tau_ty') = splitForAllTys (dataConRepType data_con') in 
1577            let (formal_arg_tys', _)     = splitFunTys formal_tau_ty' in
1578            let formal_env'           = formalIlxEnv env formal_tyvars' in 
1579
1580            vcat [vcat (ilxMapPlaceArgs 0 pushArg env tm_args'),
1581                    sep [text "newobj void ",
1582                         ilxTyConApp env tycon' rep_ty_args',
1583                         text "::.ctor",
1584                         pprValArgTys ilxTypeR formal_env' (map deepIlxRepType formal_arg_tys')
1585                    ]
1586              ]
1587  | otherwise
1588     -- Now all other constructions
1589      =  --  Assume C :: forall a. a -> T a -> T a
1590         --      ldloc x         arg of type Int
1591         --      ldloc y         arg of type T Int
1592         --      newdata classunion T<Int32>, C(!0, T <!0>)
1593         --
1594         let tycon   = dataConTyCon data_con in 
1595         let (formal_tyvars, formal_tau_ty) = splitForAllTys (dataConRepType data_con) in
1596         let (formal_arg_tys, _)     = splitFunTys formal_tau_ty in 
1597
1598        vcat [vcat (ilxMapPlaceArgs 0 pushArg env tm_args),
1599           sep [ text "newdata",
1600                 nest 2 (ilxTyConApp env tycon rep_ty_args <> comma),
1601                 nest 2 (ilxConRef env data_con)
1602           ]
1603         ]
1604  where
1605    tycon   = dataConTyCon data_con 
1606    rep_ty_args = map deepIlxRepType ty_args
1607    (ty_args,tm_args) = if isAlgTyCon tycon then splitTyArgs (tyConTyVars tycon) args  else splitTyArgs1 args
1608
1609 -- Split some type arguments off, throwing away the higher kinded ones for the moment.
1610 -- Base the higher-kinded checks off a corresponding list of formals.
1611 splitTyArgs :: [Var]            -- Formals
1612             -> [StgArg]         -- Actuals
1613             -> ([Type], [StgArg])
1614 splitTyArgs (htv:ttv) (StgTypeArg h:t) 
1615    | isIlxTyVar htv = ((h:l), r) 
1616    | otherwise = trace "splitTyArgs: threw away higher kinded type arg" (l, r) 
1617    where (l,r) = splitTyArgs ttv t 
1618 splitTyArgs _ l = ([],l)
1619  
1620 -- Split some type arguments off, where none should be higher kinded
1621 splitTyArgs1 :: [StgArg] -> ([Type], [StgArg])
1622 splitTyArgs1 (StgTypeArg ty : args) = (ty:tys, args')
1623                                     where
1624                                       (tys, args') = splitTyArgs1 args
1625 splitTyArgs1 args                   = ([], args)
1626
1627 ilxConRef env data_con
1628  | isUnboxedTupleCon data_con
1629     = let data_con' = tupleCon Unboxed (length non_void_args)in 
1630       pprId data_con' <> arg_text
1631  | otherwise 
1632     = pprId data_con <> arg_text
1633   where
1634     arg_text = pprValArgTys ilxTypeL env' (map deepIlxRepType non_void_args)
1635     non_void_args = filter (not . isVoidIlxRepType) arg_tys
1636     (tyvars, tau_ty) = splitForAllTys (dataConRepType data_con)
1637     (arg_tys, _)     = splitFunTys tau_ty
1638     env'             = formalIlxEnv env tyvars
1639
1640
1641
1642
1643 \end{code}
1644
1645
1646 %************************************************************************
1647 %*                                                                      *
1648 \subsection{PrimOps and Prim Representations}                           *
1649 %************************************************************************
1650
1651 \begin{code}
1652
1653 ilxPrimApp env op              args ret_ty = ilxPrimOpTable op args env
1654
1655
1656 type IlxTyFrag = IlxEnv -> SDoc
1657 ilxType s env = text s
1658
1659 ilxLift ty env = text "thunk" <> angleBrackets (ty env)
1660
1661 ilxTypeSeq :: [IlxTyFrag] -> IlxTyFrag
1662 ilxTypeSeq ops env = hsep (map (\x -> x env) ops)
1663
1664 tyPrimConTable :: UniqFM ([Type] -> IlxTyFrag)
1665 tyPrimConTable = 
1666   listToUFM [(addrPrimTyConKey,         (\_ -> repAddr)),
1667 --           (fileStreamPrimTyConKey,   (\_ -> repFileStream)),
1668              (foreignObjPrimTyConKey,   (\_ -> repForeign)),
1669              (stablePtrPrimTyConKey,    (\[ty] -> repStablePtr {- (ilxTypeL2 ty) -})),
1670              (stableNamePrimTyConKey,   (\[ty] -> repStableName {- (ilxTypeL2 ty) -} )),
1671              (charPrimTyConKey,         (\_ -> repChar)),
1672              (wordPrimTyConKey,         (\_ -> repWord)),
1673              (byteArrayPrimTyConKey,    (\_ -> repByteArray)),
1674              (intPrimTyConKey,          (\_ -> repInt)),
1675              (int64PrimTyConKey,        (\_ -> repInt64)),
1676              (word64PrimTyConKey,       (\_ -> repWord64)),
1677              (floatPrimTyConKey,        (\_ -> repFloat)),
1678              (doublePrimTyConKey,       (\_ -> repDouble)),
1679               -- These can all also accept unlifted parameter types so we explicitly lift.
1680              (arrayPrimTyConKey,        (\[ty] -> repArray (ilxTypeL2 ty))),
1681              (mutableArrayPrimTyConKey,         (\[_, ty] -> repMutArray (ilxTypeL2 ty))),
1682              (weakPrimTyConKey,         (\[ty] -> repWeak (ilxTypeL2 ty))),
1683              (mVarPrimTyConKey,         (\[_, ty] -> repMVar (ilxTypeL2 ty))),
1684              (mutVarPrimTyConKey,       (\[ty1, ty2] -> repMutVar (ilxTypeL2 ty1) (ilxTypeL2 ty2))),
1685              (mutableByteArrayPrimTyConKey,     (\_ -> repByteArray)),
1686              (threadIdPrimTyConKey,     (\_ -> repThread)),
1687              (bcoPrimTyConKey,  (\_ -> repBCO))
1688              ]
1689
1690 ilxTypeL2 :: Type -> IlxTyFrag
1691 ilxTypeL2 ty env = ilxTypeL env ty
1692 ilxTypeR2 :: Type -> IlxTyFrag
1693 ilxTypeR2 ty env = ilxTypeR env ty
1694
1695 ilxMethTyVarA = ilxType "!!0"
1696 ilxMethTyVarB = ilxType "!!1"
1697 prelGHCReference :: IlxTyFrag
1698 prelGHCReference env =
1699    if ilxEnvModule env == mkHomeModule (mkModuleName "PrelGHC") then empty
1700    else if inPrelude then moduleNameReference (mkModuleName "PrelGHC")
1701    else basePackageReference
1702
1703 prelBaseReference :: IlxTyFrag
1704 prelBaseReference env =
1705    if ilxEnvModule env == mkHomeModule (mkModuleName "PrelBase") then empty
1706    else if inPrelude then moduleNameReference (mkModuleName "PrelBase")
1707    else basePackageReference
1708
1709 repThread = ilxType "class [mscorlib]System.Threading.Thread /* ThreadId# */ "
1710 repByteArray = ilxType "unsigned int8[] /* ByteArr# */ "
1711 --repFileStream = text "void * /* FileStream# */ "  -- text "class [mscorlib]System.IO.FileStream"
1712 repInt = ilxType "int32"
1713 repWord = ilxType "unsigned int32"
1714 repAddr =ilxType "/* Addr */ void *"
1715 repInt64 = ilxType "int64"
1716 repWord64 = ilxType "unsigned int64"
1717 repFloat = ilxType "float32"
1718 repDouble = ilxType "float64"
1719 repChar = ilxType "/* Char */ unsigned int8"
1720 repForeign = ilxTypeSeq [ilxType "class ",prelGHCReference,ilxType "PrelGHC_Foreignzh"]
1721 repInteger = ilxUnboxedPairRep repInt repByteArray
1722 repIntegerPair = ilxUnboxedQuadRep repInt repByteArray repInt repByteArray
1723 repArray ty = ilxTypeSeq [ty,ilxType "[]"]
1724 repMutArray ty = ilxTypeSeq [ty,ilxType "[]"]
1725 repMVar ty = ilxTypeSeq [ilxType "class ",prelGHCReference,ilxType "PrelGHC_MVarzh",ilxTyParams [ty]]
1726 repMutVar _ ty2 = ilxTypeSeq [ilxType "class ",prelGHCReference,ilxType "PrelGHC_MutVarzh",ilxTyParams [ty2]]
1727 repWeak ty1 = ilxTypeSeq [ilxType "class ",prelGHCReference,ilxType "PrelGHC_Weakzh",ilxTyParams [ty1]]
1728 repStablePtr {- ty1 -} = ilxTypeSeq [ilxType "class ",prelGHCReference,ilxType "PrelGHC_StablePtrzh" {- ,ilxTyParams [ty1] -} ]
1729 repStableName {- ty1 -}  = ilxTypeSeq [ilxType "class ",prelGHCReference,ilxType "PrelGHC_StableNamezh" {- ,ilxTyParams [ty1] -} ]
1730 classWeak = ilxTypeSeq [ilxType "class ",prelGHCReference,ilxType "PrelGHC_Weakzh"]
1731 repBCO = ilxTypeSeq [ilxType "class ",prelGHCReference,ilxType "PrelGHC_BCOzh"]
1732
1733 ilxTyPair l r = ilxTyParams [l,r]
1734 ilxTyTriple l m r = ilxTyParams [l,m,r]
1735 ilxTyQuad l m1 m2 r = ilxTyParams [l,m1,m2,r]
1736 ilxUnboxedEmptyRep = ilxTypeSeq [ilxType "value class",prelGHCReference,ilxType "PrelGHC_Z1H"]
1737 ilxUnboxedPairRep l r = ilxTypeSeq [ilxType "value class",prelGHCReference,ilxType "PrelGHC_Z2H",ilxTyPair l r]
1738 ilxUnboxedTripleRep l m r = ilxTypeSeq [ilxType "value class",prelGHCReference,ilxType "PrelGHC_Z3H",ilxTyTriple l m r]
1739 ilxUnboxedQuadRep l m1 m2 r = ilxTypeSeq [ilxType "value class",prelGHCReference,ilxType "PrelGHC_Z4H",ilxTyQuad l m1 m2 r]
1740
1741 ilxTyIO b = ilxTypeSeq [ilxType "(func ( /* unit skipped */ ) --> ", b, ilxType ")"]
1742
1743 ilxTyParams :: [IlxTyFrag] -> IlxTyFrag
1744 ilxTyParams [] env = empty
1745 ilxTyParams l env = angleBrackets (ilxTyParamsAux l env)
1746   where
1747    ilxTyParamsAux [] env = empty
1748    ilxTyParamsAux [h] env = h env
1749    ilxTyParamsAux (h:t) env = h env <> text "," <+> ilxTyParamsAux t env
1750    ilxTyParams [] env = empty
1751
1752
1753 type IlxOpFrag = IlxEnv -> SDoc
1754 ilxOp :: String -> IlxOpFrag
1755 ilxOp s env = text s
1756 ilxOpSeq :: [IlxOpFrag] -> IlxOpFrag
1757 ilxOpSeq ops env = hsep (map (\x -> x env) ops)
1758
1759 ilxParams :: [IlxOpFrag] -> IlxOpFrag
1760 ilxParams l env = parens (ilxParamsAux l env)
1761   where
1762    ilxParamsAux [] env = empty
1763    ilxParamsAux [h] env = h env
1764    ilxParamsAux (h:t) env = h env <> text "," <+> ilxParamsAux t env
1765
1766
1767 ilxMethodRef rty cls nm tyargs args = 
1768     ilxOpSeq [rty,cls,ilxOp "::",ilxOp nm,
1769               ilxTyParams tyargs,ilxParams args]
1770
1771 ilxCall m = ilxOpSeq [ilxOp "call", m]
1772
1773 ilxSupportClass = ilxOpSeq [prelGHCReference, ilxOp "'GHC.support'"]
1774 ilxSuppMeth rty nm tyargs args = ilxMethodRef rty ilxSupportClass nm tyargs args
1775
1776 ilxCallSuppMeth rty nm tyargs args  = ilxCall (ilxSuppMeth rty nm tyargs args)
1777
1778 ilxMkBool :: IlxOpFrag
1779 ilxMkBool =  ilxOpSeq [ilxOp "call class",prelBaseReference,
1780                        ilxOp "PrelBase_Bool",
1781                        prelGHCReference,ilxOp "GHC.support::mkBool(bool)"]
1782 ilxCgt = ilxOpSeq [ilxOp "cgt",ilxMkBool]
1783 ilxCge = ilxOpSeq [ilxOp "clt ldc.i4 0 ceq ",ilxMkBool]
1784 ilxClt = ilxOpSeq [ilxOp "clt ",ilxMkBool]
1785 ilxCle = ilxOpSeq [ilxOp "cgt ldc.i4 0 ceq ",ilxMkBool]
1786 ilxCeq = ilxOpSeq [ilxOp "ceq ",ilxMkBool]
1787 ilxCne = ilxOpSeq [ilxOp "ceq ldc.i4 0 ceq " ,ilxMkBool]
1788 ilxCgtUn = ilxOpSeq [ilxOp "cgt.un ",ilxMkBool]
1789 ilxCgeUn  = ilxOpSeq [ilxOp "clt.un ldc.i4 0 ceq ",ilxMkBool]
1790 ilxCltUn = ilxOpSeq [ilxOp "clt.un ",ilxMkBool]
1791 ilxCleUn = ilxOpSeq [ilxOp "cgt.un ldc.i4 0 ceq ",ilxMkBool]
1792
1793 ilxAddrOfForeignOp = ilxOpSeq [ilxOp "ldfld void *" , repForeign, ilxOp "::contents"]
1794 ilxAddrOfByteArrOp = ilxOp "ldc.i4 0 ldelema unsigned int8"
1795
1796 ilxPrimOpTable :: PrimOp -> [StgArg] -> IlxOpFrag
1797 ilxPrimOpTable op
1798   = case op of
1799         CharGtOp    -> simp_op ilxCgt
1800         CharGeOp    -> simp_op ilxCge
1801         CharEqOp    -> simp_op ilxCeq
1802         CharNeOp    -> simp_op ilxCne
1803         CharLtOp    -> simp_op ilxClt
1804         CharLeOp    -> simp_op ilxCle
1805
1806         OrdOp       -> simp_op (ilxOp "conv.i4") -- chars represented by UInt32 (u4)
1807         ChrOp       -> simp_op (ilxOp "conv.u4")
1808
1809         IntGtOp     -> simp_op ilxCgt
1810         IntGeOp     -> simp_op ilxCge
1811         IntEqOp     -> simp_op ilxCeq
1812         IntNeOp     -> simp_op ilxCne
1813         IntLtOp     -> simp_op ilxClt
1814         IntLeOp     -> simp_op ilxCle
1815
1816         Narrow8IntOp   -> simp_op  (ilxOp"conv.i1")
1817         Narrow16IntOp  -> simp_op (ilxOp "conv.i2")
1818         Narrow32IntOp  -> simp_op (ilxOp "conv.i4")
1819         Narrow8WordOp  -> simp_op (ilxOp "conv.u1")
1820         Narrow16WordOp -> simp_op (ilxOp "conv.u2")
1821         Narrow32WordOp -> simp_op (ilxOp "conv.u4")
1822
1823         WordGtOp     -> simp_op ilxCgtUn
1824         WordGeOp     -> simp_op ilxCgeUn
1825         WordEqOp     -> simp_op ilxCeq
1826         WordNeOp     -> simp_op ilxCne
1827         WordLtOp     -> simp_op ilxCltUn
1828         WordLeOp     -> simp_op ilxCleUn
1829
1830         AddrGtOp     -> simp_op ilxCgt
1831         AddrGeOp     -> simp_op ilxCge
1832         AddrEqOp     -> simp_op ilxCeq
1833         AddrNeOp     -> simp_op ilxCne
1834         AddrLtOp     -> simp_op ilxClt
1835         AddrLeOp     -> simp_op ilxCle
1836
1837         FloatGtOp     -> simp_op ilxCgt
1838         FloatGeOp     -> simp_op ilxCge
1839         FloatEqOp     -> simp_op ilxCeq
1840         FloatNeOp     -> simp_op ilxCne
1841         FloatLtOp     -> simp_op ilxClt
1842         FloatLeOp     -> simp_op ilxCle
1843
1844         DoubleGtOp     -> simp_op ilxCgt
1845         DoubleGeOp     -> simp_op ilxCge
1846         DoubleEqOp     -> simp_op ilxCeq
1847         DoubleNeOp     -> simp_op ilxCne
1848         DoubleLtOp     -> simp_op ilxClt
1849         DoubleLeOp     -> simp_op ilxCle
1850
1851     -- Int#-related ops:
1852         IntAddOp    -> simp_op (ilxOp "add")
1853         IntSubOp    -> simp_op (ilxOp "sub")
1854         IntMulOp    -> simp_op (ilxOp "mul")
1855         IntQuotOp   -> simp_op (ilxOp "div")
1856         IntNegOp    -> simp_op (ilxOp "neg")
1857         IntRemOp    -> simp_op (ilxOp "rem")
1858
1859     -- Addr# ops:
1860         AddrAddOp  -> simp_op (ilxOp "add")
1861         AddrSubOp  -> simp_op (ilxOp "sub")
1862         AddrRemOp  -> simp_op (ilxOp "rem")
1863         Int2AddrOp -> warn_op "int2Addr" (simp_op (ilxOp "/* PrimOp int2Addr */ "))
1864         Addr2IntOp -> warn_op "addr2Int" (simp_op (ilxOp "/* PrimOp addr2Int */ "))
1865
1866     -- Word#-related ops:
1867         WordAddOp    -> simp_op (ilxOp "add")
1868         WordSubOp    -> simp_op (ilxOp "sub")
1869         WordMulOp    -> simp_op (ilxOp "mul")
1870         WordQuotOp   -> simp_op (ilxOp "div")
1871         WordRemOp    -> simp_op (ilxOp "rem")
1872
1873         ISllOp      -> simp_op (ilxOp "shl")
1874         ISraOp      -> simp_op (ilxOp "shr")
1875         ISrlOp      -> simp_op (ilxOp "shr.un")
1876         IntAddCOp   -> simp_op (ilxCallSuppMeth (ilxUnboxedPairRep repInt repInt) "IntAddCOp" [] [repInt, repInt])
1877         IntSubCOp   -> simp_op (ilxCallSuppMeth (ilxUnboxedPairRep repInt repInt) "IntSubCOp" [] [repInt, repInt])
1878         IntGcdOp    -> simp_op (ilxCallSuppMeth repInt "IntGcdOp" [] [repInt, repInt])
1879
1880
1881     -- Word#-related ops:
1882         AndOp       -> simp_op (ilxOp "and") 
1883         OrOp        -> simp_op (ilxOp "or") 
1884         NotOp       -> simp_op (ilxOp "not") 
1885         XorOp       -> simp_op (ilxOp "xor") 
1886         SllOp       -> simp_op (ilxOp "shl") 
1887         SrlOp       -> simp_op (ilxOp "shr") 
1888         Word2IntOp  -> simp_op (ilxOp "conv.i4")
1889         Int2WordOp  -> simp_op (ilxOp "conv.u4")
1890
1891     -- Float#-related ops:
1892         FloatAddOp   -> simp_op (ilxOp "add")
1893         FloatSubOp   -> simp_op (ilxOp "sub")
1894         FloatMulOp   -> simp_op (ilxOp "mul")
1895         FloatDivOp   -> simp_op (ilxOp "div")
1896         FloatNegOp   -> simp_op (ilxOp "neg")
1897         Float2IntOp  -> simp_op (ilxOp "conv.i4")
1898         Int2FloatOp  -> simp_op (ilxOp "conv.r4")
1899
1900         DoubleAddOp     -> simp_op (ilxOp "add")
1901         DoubleSubOp     -> simp_op (ilxOp "sub")
1902         DoubleMulOp     -> simp_op (ilxOp "mul")
1903         DoubleDivOp     -> simp_op (ilxOp "div")
1904         DoubleNegOp     -> simp_op (ilxOp "neg")
1905         Double2IntOp    -> simp_op (ilxOp "conv.i4")
1906         Int2DoubleOp    -> simp_op (ilxOp "conv.r4")
1907         Double2FloatOp  -> simp_op (ilxOp "conv.r4")
1908         Float2DoubleOp  -> simp_op (ilxOp "conv.r8")
1909         DoubleDecodeOp  -> simp_op (ilxCallSuppMeth (ilxUnboxedTripleRep repInt repInt repByteArray) "decodeDouble" [] [ilxType "float64"])
1910         FloatDecodeOp   -> simp_op (ilxCallSuppMeth (ilxUnboxedTripleRep repInt repInt repByteArray) "decodeFloat" [] [ilxType "float32"])
1911
1912         FloatExpOp   -> simp_op (ilxOp "conv.r8 call float64 [mscorlib]System.Math::Exp(float64) conv.r4")
1913         FloatLogOp   -> simp_op (ilxOp "conv.r8 call float64 [mscorlib]System.Math::Log(float64) conv.r4")
1914         FloatSqrtOp  -> simp_op (ilxOp "conv.r8 call float64 [mscorlib]System.Math::Sqrt(float64) conv.r4")
1915         FloatSinOp   -> simp_op (ilxOp "conv.r8 call float64 [mscorlib]System.Math::Sin(float64) conv.r4")
1916         FloatCosOp   -> simp_op (ilxOp "conv.r8 call float64 [mscorlib]System.Math::Cos(float64) conv.r4")
1917         FloatTanOp   -> simp_op (ilxOp "conv.r8 call float64 [mscorlib]System.Math::Tan(float64) conv.r4")
1918         FloatAsinOp  -> simp_op (ilxOp "conv.r8 call float64 [mscorlib]System.Math::Asin(float64) conv.r4")
1919         FloatAcosOp  -> simp_op (ilxOp "conv.r8 call float64 [mscorlib]System.Math::Acos(float64) conv.r4")
1920         FloatAtanOp  -> simp_op (ilxOp "conv.r8 call float64 [mscorlib]System.Math::Atan(float64) conv.r4")
1921         FloatSinhOp  -> simp_op (ilxOp "conv.r8 call float64 [mscorlib]System.Math::Sinh(float64) conv.r4")
1922         FloatCoshOp  -> simp_op (ilxOp "conv.r8 call float64 [mscorlib]System.Math::Cosh(float64) conv.r4")
1923         FloatTanhOp  -> simp_op (ilxOp "conv.r8 call float64 [mscorlib]System.Math::Tanh(float64) conv.r4")
1924         FloatPowerOp -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Pow(float64, float64) conv.r4") --  ** op, make use of implicit cast to r8...
1925
1926         DoubleExpOp   -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Exp(float64)")
1927         DoubleLogOp   -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Log(float64)")
1928         DoubleSqrtOp  -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Sqrt(float64)")
1929           
1930         DoubleSinOp   -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Sin(float64)")
1931         DoubleCosOp   -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Cos(float64)")
1932         DoubleTanOp   -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Tan(float64)")
1933           
1934         DoubleAsinOp   -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Asin(float64)")
1935         DoubleAcosOp   -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Acos(float64)")
1936         DoubleAtanOp   -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Atan(float64)")
1937           
1938         DoubleSinhOp   -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Sinh(float64)")
1939         DoubleCoshOp   -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Cosh(float64)")
1940         DoubleTanhOp   -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Tanh(float64)")
1941           
1942         DoublePowerOp  -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Pow(float64, float64)")
1943
1944     -- Integer (and related...) ops: bail out to support routines
1945         IntegerAndOp       -> simp_op (ilxCallSuppMeth repInteger "IntegerAndOp" [] [repInt, repByteArray, repInt, repByteArray])
1946         IntegerOrOp        -> simp_op (ilxCallSuppMeth repInteger "IntegerOrOp" [] [repInt, repByteArray, repInt, repByteArray])
1947         IntegerXorOp       -> simp_op (ilxCallSuppMeth repInteger "IntegerXorOp" [] [repInt, repByteArray, repInt, repByteArray])
1948         IntegerComplementOp -> simp_op (ilxCallSuppMeth repInteger "IntegerComplementOp" [] [repInt, repByteArray])
1949         IntegerAddOp       -> simp_op (ilxCallSuppMeth repInteger "IntegerAddOp" [] [repInt, repByteArray, repInt, repByteArray])
1950         IntegerSubOp       -> simp_op (ilxCallSuppMeth repInteger "IntegerSubOp" [] [repInt, repByteArray, repInt, repByteArray])
1951         IntegerMulOp       -> simp_op (ilxCallSuppMeth repInteger "IntegerMulOp" [] [repInt, repByteArray, repInt, repByteArray])
1952         IntegerGcdOp       -> simp_op (ilxCallSuppMeth repInteger "IntegerGcdOp" [] [repInt, repByteArray, repInt, repByteArray])
1953         IntegerQuotRemOp   -> simp_op (ilxCallSuppMeth repIntegerPair "IntegerQuotRemOp" [] [repInt, repByteArray, repInt, repByteArray])
1954         IntegerDivModOp    -> simp_op (ilxCallSuppMeth repIntegerPair "IntegerDivModOp" [] [repInt, repByteArray, repInt, repByteArray])
1955         IntegerIntGcdOp    -> simp_op (ilxCallSuppMeth repInt "IntegerIntGcdOp" [] [repInt, repByteArray, repInt])
1956         IntegerDivExactOp  -> simp_op (ilxCallSuppMeth repInteger "IntegerDivExactOp" [] [repInt, repByteArray, repInt, repByteArray])
1957         IntegerQuotOp      -> simp_op (ilxCallSuppMeth repInteger "IntegerQuotOp" [] [repInt, repByteArray, repInt, repByteArray])
1958         IntegerRemOp       -> simp_op (ilxCallSuppMeth repInteger "IntegerRemOp" [] [repInt, repByteArray, repInt, repByteArray])
1959         IntegerCmpOp       -> simp_op (ilxCallSuppMeth repInt "IntegerCmpOp" [] [repInt, repByteArray, repInt, repByteArray])
1960         IntegerCmpIntOp    -> simp_op (ilxCallSuppMeth repInt "IntegerCmpIntOp" [] [repInt, repByteArray, repInt])
1961         Integer2IntOp      -> simp_op (ilxCallSuppMeth repInt "Integer2IntOp" [] [repInt, repByteArray])
1962         Integer2WordOp     -> simp_op (ilxCallSuppMeth repWord "Integer2WordOp" [] [repInt, repByteArray])
1963         Int2IntegerOp      -> simp_op (ilxCallSuppMeth repInteger "Int2IntegerOp" [] [repInt])
1964         Word2IntegerOp     -> simp_op (ilxCallSuppMeth repInteger "Word2IntegerOp" [] [repWord])
1965 --      IntegerToInt64Op   -> simp_op (ilxCallSuppMeth repInt64 "IntegerToInt64Op" [] [repInt,repByteArray])
1966         Int64ToIntegerOp   -> simp_op (ilxCallSuppMeth repInteger "Int64ToIntegerOp" [] [repInt64])
1967 --      IntegerToWord64Op  -> simp_op (ilxCallSuppMeth repWord64 "IntegerToWord64Op" [] [repInt,repByteArray])
1968         Word64ToIntegerOp  -> simp_op (ilxCallSuppMeth repInteger "Word64ToIntegerOp" [] [repWord64])
1969
1970
1971
1972         IndexByteArrayOp_Char      -> simp_op (ilxOp "ldelem.u1")
1973         IndexByteArrayOp_WideChar  -> simp_op (ilxOp "ldelem.u4")
1974         IndexByteArrayOp_Int       -> simp_op (ilxOp "ldelem.i4")
1975         IndexByteArrayOp_Word      -> simp_op (ilxOp "ldelem.u4")
1976         IndexByteArrayOp_Addr      -> simp_op (ilxOp "ldelem.u")
1977         IndexByteArrayOp_Float     -> simp_op (ilxOp "ldelem.r4")
1978         IndexByteArrayOp_Double    -> simp_op (ilxOp "ldelem.r8")
1979         IndexByteArrayOp_StablePtr -> simp_op (ilxOp "ldelem.ref")
1980         IndexByteArrayOp_Int8     -> simp_op (ilxOp "ldelem.i1")
1981         IndexByteArrayOp_Int16     -> simp_op (ilxOp "ldelem.i2")
1982         IndexByteArrayOp_Int32     -> simp_op (ilxOp "ldelem.i4")
1983         IndexByteArrayOp_Int64     -> simp_op (ilxOp "ldelem.i8")
1984         IndexByteArrayOp_Word8    -> simp_op (ilxOp "ldelem.u1")
1985         IndexByteArrayOp_Word16    -> simp_op (ilxOp "ldelem.u2")
1986         IndexByteArrayOp_Word32    -> simp_op (ilxOp "ldelem.u4")
1987         IndexByteArrayOp_Word64    -> simp_op (ilxOp "ldelem.u8")
1988
1989             {- should be monadic??? -}
1990         ReadByteArrayOp_Char      -> simp_op (ilxOp "ldelem.u1")
1991         ReadByteArrayOp_WideChar  -> simp_op (ilxOp "ldelem.u4")
1992         ReadByteArrayOp_Int       -> simp_op (ilxOp "ldelem.i4")
1993         ReadByteArrayOp_Word      -> simp_op (ilxOp "ldelem.u4")
1994         ReadByteArrayOp_Addr      -> simp_op (ilxOp "ldelem.u")
1995         ReadByteArrayOp_Float     -> simp_op (ilxOp "ldelem.r4")
1996         ReadByteArrayOp_Double    -> simp_op (ilxOp "ldelem.r8")
1997         ReadByteArrayOp_StablePtr -> simp_op (ilxOp "ldelem.ref")
1998         ReadByteArrayOp_Int8     -> simp_op (ilxOp "ldelem.i1")
1999         ReadByteArrayOp_Int16     -> simp_op (ilxOp "ldelem.i2")
2000         ReadByteArrayOp_Int32     -> simp_op (ilxOp "ldelem.i4")
2001         ReadByteArrayOp_Int64     -> simp_op (ilxOp "ldelem.i8")
2002         ReadByteArrayOp_Word8    -> simp_op (ilxOp "ldelem.u1")
2003         ReadByteArrayOp_Word16    -> simp_op (ilxOp "ldelem.u2")
2004         ReadByteArrayOp_Word32    -> simp_op (ilxOp "ldelem.u4")
2005         ReadByteArrayOp_Word64    -> simp_op (ilxOp "ldelem.u8")
2006                  {-   MutByteArr# s -> Int# -> State# s -> (# State# s, Char# #) -}
2007                  {- ByteArr# -> Int# -> Char# -}
2008
2009
2010         WriteByteArrayOp_Char      -> simp_op (ilxOp "stelem.u1")
2011         WriteByteArrayOp_WideChar   -> simp_op (ilxOp "stelem.u4")
2012         WriteByteArrayOp_Int       -> simp_op (ilxOp "stelem.i4")
2013         WriteByteArrayOp_Word      -> simp_op (ilxOp "stelem.u4")
2014         WriteByteArrayOp_Addr      -> simp_op (ilxOp "stelem.u")
2015         WriteByteArrayOp_Float     -> simp_op (ilxOp "stelem.r4")
2016         WriteByteArrayOp_Double    -> simp_op (ilxOp "stelem.r8")
2017         WriteByteArrayOp_StablePtr -> simp_op (ilxOp "stelem.ref")
2018         WriteByteArrayOp_Int8     -> simp_op (ilxOp "stelem.i1")
2019         WriteByteArrayOp_Int16     -> simp_op (ilxOp "stelem.i2")
2020         WriteByteArrayOp_Int32     -> simp_op (ilxOp "stelem.i4")
2021         WriteByteArrayOp_Int64     -> simp_op (ilxOp "stelem.i8")
2022         WriteByteArrayOp_Word8    -> simp_op (ilxOp "stelem.u1")
2023         WriteByteArrayOp_Word16    -> simp_op (ilxOp "stelem.u2")
2024         WriteByteArrayOp_Word32    -> simp_op (ilxOp "stelem.u4")
2025         WriteByteArrayOp_Word64    -> simp_op (ilxOp "stelem.i8 /* nb. no stelem.u8 */")
2026                  {- MutByteArr# s -> Int# -> Char# -> State# s -> State# s -}
2027
2028         IndexOffAddrOp_Char    -> simp_op (ilxOp "sizeof unsigned int8 mul add ldind.u1")
2029         IndexOffAddrOp_WideChar    -> simp_op (ilxOp "sizeof int32 mul add ldind.u4")
2030         IndexOffAddrOp_Int     -> simp_op (ilxOp "sizeof int32 mul add ldind.i4")
2031         IndexOffAddrOp_Word    -> simp_op (ilxOp "sizeof int32 mul add ldind.u4")
2032         IndexOffAddrOp_Addr    -> simp_op (ilxOp "sizeof native unsigned int mul add ldind.i")
2033         IndexOffAddrOp_StablePtr   -> simp_op (ilxOp "sizeof native unsigned int mul add ldind.ref")
2034         IndexOffAddrOp_Float   -> simp_op (ilxOp "sizeof float32 mul add ldind.r4")
2035         IndexOffAddrOp_Double  -> simp_op (ilxOp "sizeof float64 mul add ldind.r8")
2036         IndexOffAddrOp_Int8   -> simp_op (ilxOp "sizeof int8 mul add ldind.i1")
2037         IndexOffAddrOp_Int16   -> simp_op (ilxOp "sizeof int16 mul add ldind.i2")
2038         IndexOffAddrOp_Int32   -> simp_op (ilxOp "sizeof int32 mul add ldind.i4")
2039         IndexOffAddrOp_Int64   -> simp_op (ilxOp "sizeof int64 mul add ldind.i8")
2040         IndexOffAddrOp_Word8  -> simp_op (ilxOp "sizeof unsigned int8 mul add ldind.u1")
2041         IndexOffAddrOp_Word16 -> simp_op (ilxOp "sizeof unsigned int16 mul add ldind.u2")
2042         IndexOffAddrOp_Word32  -> simp_op (ilxOp "sizeof unsigned int32 mul add ldind.u4")
2043         IndexOffAddrOp_Word64  -> simp_op (ilxOp "sizeof int64 mul add ldind.u8")
2044
2045         -- ForeignObj: load the address inside the object first
2046         -- TODO: is this remotely right?
2047         EqForeignObj                 -> warn_op "eqForeignObj" (simp_op (ilxOp "pop /* PrimOp eqForeignObj */ "))
2048         IndexOffForeignObjOp_Char    -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof unsigned int8 mul add ldind.u1"])
2049         IndexOffForeignObjOp_WideChar    -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof int32 mul add ldind.u4"])
2050         IndexOffForeignObjOp_Int     -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof int32 mul add ldind.i4"])
2051         IndexOffForeignObjOp_Word    -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof unsigned int32 mul add ldind.u4"])
2052         IndexOffForeignObjOp_Addr    ->  arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof native unsigned int mul add ldind.i  "])
2053         IndexOffForeignObjOp_StablePtr    ->  ty1_arg2_op (\ty fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof native unsigned int mul add ldind.ref  "])
2054         IndexOffForeignObjOp_Float   -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof float32 mul add ldind.r4"])
2055         IndexOffForeignObjOp_Double  -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof float64 mul add ldind.r8"])
2056         IndexOffForeignObjOp_Int8   -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof int8 mul add ldind.i1"])
2057         IndexOffForeignObjOp_Int16   -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof int16 mul add ldind.i2"])
2058         IndexOffForeignObjOp_Int32   -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof int32 mul add ldind.i4"])
2059         IndexOffForeignObjOp_Int64   -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof int64 mul add ldind.i8"])
2060         IndexOffForeignObjOp_Word8  -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof unsigned int8 mul add ldind.u1"])
2061         IndexOffForeignObjOp_Word16  -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof unsigned int16 mul add ldind.u2"])
2062         IndexOffForeignObjOp_Word32  -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof unsigned int32 mul add ldind.u4"])
2063         IndexOffForeignObjOp_Word64  -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof unsigned int64 mul add ldind.u8"])
2064
2065         ReadOffAddrOp_Char   -> simp_op (ilxOp "sizeof unsigned int8 mul add ldind.u1")
2066         ReadOffAddrOp_WideChar -> simp_op (ilxOp "sizeof int32 mul add ldind.u4")
2067         ReadOffAddrOp_Int    -> simp_op (ilxOp "sizeof int32 mul add ldind.i4")
2068         ReadOffAddrOp_Word   -> simp_op (ilxOp "sizeof unsigned int32 mul add ldind.u4")
2069         ReadOffAddrOp_Addr   -> simp_op (ilxOp "sizeof native unsigned int mul add ldind.i")
2070         ReadOffAddrOp_Float  -> simp_op (ilxOp "sizeof float32 mul add ldind.r4")
2071         ReadOffAddrOp_Double -> simp_op (ilxOp "sizeof float64 mul add ldind.r8")
2072         ReadOffAddrOp_StablePtr  -> simp_op (ilxOp "sizeof native unsigned int mul add ldind.ref")
2073         ReadOffAddrOp_Int8  -> simp_op (ilxOp "sizeof int8 mul add ldind.i1")
2074         ReadOffAddrOp_Int16  -> simp_op (ilxOp "sizeof int16 mul add ldind.i2")
2075         ReadOffAddrOp_Int32  -> simp_op (ilxOp "sizeof int32 mul add ldind.i4")
2076         ReadOffAddrOp_Int64  -> simp_op (ilxOp "sizeof int64 mul add ldind.i8")
2077         ReadOffAddrOp_Word8 -> simp_op (ilxOp "sizeof unsigned int8 mul add ldind.u1")
2078         ReadOffAddrOp_Word16 -> simp_op (ilxOp "sizeof unsigned int16 mul add ldind.u2")
2079         ReadOffAddrOp_Word32 -> simp_op (ilxOp "sizeof unsigned int32 mul add ldind.u4")
2080         ReadOffAddrOp_Word64 -> simp_op (ilxOp "sizeof unsigned int64 mul add ldind.u8")
2081                   {-    Addr# -> Int# -> Char# -> State# s -> State# s -} 
2082
2083         WriteOffAddrOp_Char   -> ty1_arg4_op (\sty addr n v s -> ilxOpSeq [addr, n, ilxOp "add", v, ilxOp "stind.u1"])
2084         WriteOffAddrOp_WideChar   -> ty1_arg4_op (\sty addr n v s -> ilxOpSeq [addr, n, ilxOp "sizeof int32 mul add", v, ilxOp "stind.u4"])
2085         WriteOffAddrOp_Int    -> ty1_arg4_op (\sty addr n v s -> ilxOpSeq [addr, n, ilxOp "sizeof int32 mul add", v, ilxOp "stind.i4"])
2086         WriteOffAddrOp_Word   -> ty1_arg4_op (\sty addr n v s -> ilxOpSeq [addr, n, ilxOp "sizeof int32 mul add", v, ilxOp "stind.u4"])
2087         WriteOffAddrOp_Addr   -> ty1_arg4_op (\sty addr n v s -> ilxOpSeq [addr, n, ilxOp "sizeof native unsigned int mul add", v, ilxOp "stind.i"])
2088         WriteOffAddrOp_ForeignObj   -> ty1_arg4_op (\sty addr n v s -> ilxOpSeq [addr, n, ilxOp "sizeof native unsigned int mul add", v, ilxOp "stind.ref"])
2089         WriteOffAddrOp_Float  -> ty1_arg4_op (\sty addr n v s -> ilxOpSeq [addr, n, ilxOp "sizeof float32 mul add", v,ilxOp "stind.r4"])
2090         WriteOffAddrOp_StablePtr   -> ty2_arg4_op (\ty1 sty addr n v s -> ilxOpSeq [addr, n, ilxOp "sizeof native unsigned int mul add", v, ilxOp "stind.ref"])
2091         WriteOffAddrOp_Double -> ty1_arg4_op (\sty addr n v s -> ilxOpSeq [addr,n,ilxOp "sizeof float64 mul add",v,ilxOp "stind.r8"])
2092         WriteOffAddrOp_Int8  -> ty1_arg4_op (\sty addr n v s -> ilxOpSeq [addr,n,ilxOp "sizeof int8 mul add",v,ilxOp "stind.i1"])
2093         WriteOffAddrOp_Int16  -> ty1_arg4_op (\sty addr n v s -> ilxOpSeq [addr,n,ilxOp "sizeof int16 mul add",v,ilxOp "stind.i2"])
2094         WriteOffAddrOp_Int32  -> ty1_arg4_op (\sty addr n v s -> ilxOpSeq [addr,n,ilxOp "sizeof int32 mul add",v,ilxOp "stind.i4"])
2095         WriteOffAddrOp_Int64  -> ty1_arg4_op (\sty addr n v s -> ilxOpSeq [addr,n,ilxOp "sizeof int64 mul add",v,ilxOp "stind.i8"])
2096         WriteOffAddrOp_Word8 -> ty1_arg4_op (\sty addr n v s -> ilxOpSeq [addr,n,ilxOp "sizeof unsigned int8 mul add",v,ilxOp "stind.u1"])
2097         WriteOffAddrOp_Word16 -> ty1_arg4_op (\sty addr n v s -> ilxOpSeq [addr,n,ilxOp "sizeof unsigned int16 mul add",v,ilxOp "stind.u2"])
2098         WriteOffAddrOp_Word32 -> ty1_arg4_op (\sty addr n v s -> ilxOpSeq [addr,n,ilxOp "sizeof unsigned int32 mul add",v,ilxOp "stind.u4"])
2099         WriteOffAddrOp_Word64 -> ty1_arg4_op (\sty addr n v s -> ilxOpSeq [addr,n,ilxOp "sizeof unsigned int64 mul add",v,ilxOp "stind.u8"])
2100                   {-    Addr# -> Int# -> Char# -> State# s -> State# s -} 
2101
2102             {- should be monadic??? -}
2103         NewPinnedByteArrayOp_Char -> warn_op "newPinnedByteArray" (simp_op (ilxOp "newarr [mscorlib]System.Byte "))
2104         NewByteArrayOp_Char      -> simp_op (ilxOp "newarr [mscorlib]System.Byte")
2105 --      NewByteArrayOp_Int       -> simp_op (ilxOp "newarr [mscorlib]System.Int32")
2106 --      NewByteArrayOp_Word      -> simp_op (ilxOp "newarr [mscorlib]System.UInt32")
2107 --      NewByteArrayOp_Addr      -> simp_op (ilxOp "newarr [mscorlib]System.UInt64")
2108 --      NewByteArrayOp_Float     -> simp_op (ilxOp "newarr [mscorlib]System.Single")
2109 --      NewByteArrayOp_Double    -> simp_op (ilxOp "newarr [mscorlib]System.Double")
2110 --      NewByteArrayOp_StablePtr -> simp_op (ilxOp "newarr [mscorlib]System.UInt32")
2111 --      NewByteArrayOp_Int64     -> simp_op (ilxOp "newarr [mscorlib]System.Int64")  TODO: there is no unique for this one -}
2112 --      NewByteArrayOp_Word64    -> simp_op (ilxOp "newarr  [mscorlib]System.UInt64") -}
2113                   {- Int# -> State# s -> (# State# s, MutByteArr# s #) -}
2114         ByteArrayContents_Char   -> warn_op "byteArrayContents" (simp_op ilxAddrOfByteArrOp)
2115
2116         UnsafeFreezeByteArrayOp ->   ty1_op (\ty1  -> ilxOp "nop ")
2117                   {- MutByteArr# s -> State# s -> (# State# s, ByteArr# #) -}
2118         SizeofByteArrayOp  -> simp_op (ilxOp "ldlen")
2119                   {- ByteArr# -> Int# -}
2120
2121         SameMutableByteArrayOp -> ty1_op (\ty1  -> ilxCeq)
2122                  {- MutByteArr# s -> MutByteArr# s -> Bool -}
2123         SizeofMutableByteArrayOp -> ty1_op (\ty1  -> ilxOp "ldlen")
2124                  {- MutByteArr# s -> Int# -}
2125
2126         SameMutVarOp -> ty2_op (\ty1 ty2 -> ilxCeq)
2127                  {- MutVar# s a -> MutVar# s a -> Bool -}
2128         NewMutVarOp -> ty2_op (\ty1 ty2 -> ilxOpSeq [ilxOp "newobj void" , repMutVar ty1 ty2 , ilxOp "::.ctor(!0)"])
2129                  {- a -> State# s -> (# State# s, MutVar# s a #) -}
2130         ReadMutVarOp -> ty2_op (\ty1 ty2 ->  ilxOpSeq [ilxOp "ldfld !0" , repMutVar ty1 ty2 , ilxOp "::contents"])
2131                  {-  MutVar# s a -> State# s -> (# State# s, a #) -}
2132         WriteMutVarOp -> ty2_op (\ty1 ty2 -> ilxOpSeq [ilxOp "stfld !0" , repMutVar ty1 ty2 , ilxOp "::contents"])
2133                  {- MutVar# s a -> a -> State# s -> State# s -}
2134
2135         NewArrayOp -> ty2_op (\ty1 ty2 -> ilxCallSuppMeth (ilxType "!!0[]") "newArray" [ty1] [repInt,ilxMethTyVarA])
2136                  {- Int# -> a -> State# s -> (# State# s, MutArr# s a #) -}
2137         IndexArrayOp -> ty1_op (\ty1 -> ilxOp "ldelem.ref")
2138                  {- Array# a -> Int# -> (# a #) -}
2139         WriteArrayOp -> ty2_op (\ty1 ty2 -> ilxOp "stelem.ref")
2140                  {- MutArr# s a -> Int# -> a -> State# s -> State# s -}
2141         ReadArrayOp -> ty2_op (\ty1 ty2 -> ilxOp "ldelem.ref")
2142                  {- MutArr# s a -> Int# -> State# s -> (# State# s, a #) -}
2143         UnsafeFreezeArrayOp -> ty2_op (\ty1 ty2 -> ilxOp "nop")
2144                  {-   MutArr# s a -> State# s -> (# State# s, Array# a #) -}
2145         UnsafeThawArrayOp -> ty2_op (\ty1 ty2 -> ilxOp "nop")
2146                  {-  Array# a -> State# s -> (# State# s, MutArr# s a #) -}
2147
2148         SameMutableArrayOp -> ty2_op (\ty1 ty2 -> ilxCeq)
2149                  {- MutArr# s a -> MutArr# s a -> Bool -}
2150
2151
2152         RaiseOp -> ty2_op (\ty1 ty2 -> ilxOp "throw")
2153         CatchOp -> ty2_op (\ty1 ty2 -> 
2154                 ilxCallSuppMeth ilxMethTyVarA "'catch'" [ty1,ty2] [ilxLift (ilxTyIO (ilxType "!!0")), 
2155                                                               ilxOp "thunk<(func (!!1) --> (func ( /* unit skipped */ ) --> !!0))>"])
2156                             {-        (State# RealWorld -> (# State# RealWorld, a #) )
2157                                    -> (b -> State# RealWorld -> (# State# RealWorld, a #) ) 
2158                                    -> State# RealWorld
2159                                    -> (# State# RealWorld, a #) 
2160                              -} 
2161
2162         BlockAsyncExceptionsOp -> ty1_op (\ty1 -> 
2163                 ilxCallSuppMeth ilxMethTyVarA "blockAsyncExceptions" [ty1] [ilxLift (ilxTyIO (ilxType "!!0"))])
2164
2165                 {-     (State# RealWorld -> (# State# RealWorld, a #))
2166                     -> (State# RealWorld -> (# State# RealWorld, a #))
2167                 -}
2168
2169         UnblockAsyncExceptionsOp -> ty1_op (\ty1 -> 
2170                 ilxCallSuppMeth ilxMethTyVarA "unblockAsyncExceptions" [ty1] [ilxLift (ilxTyIO (ilxType "!!0"))])
2171
2172                 {-
2173                     State# RealWorld -> (# State# RealWorld, a #))
2174                     -> (State# RealWorld -> (# State# RealWorld, a #))
2175                 -}
2176  
2177         NewMVarOp -> ty2_op (\sty ty -> 
2178                 ilxOpSeq [ilxOp "newobj void " , repMVar ty , ilxOp "::.ctor()"])
2179                  {- State# s -> (# State# s, MVar# s a #) -}
2180
2181         TakeMVarOp -> ty2_op (\sty ty -> 
2182                 ilxCallSuppMeth ilxMethTyVarA "takeMVar" [ty] [repMVar ilxMethTyVarA])
2183                   {-  MVar# s a -> State# s -> (# State# s, a #) -}
2184
2185         -- These aren't yet right
2186         TryTakeMVarOp -> ty2_op (\sty ty -> 
2187                 ilxCallSuppMeth (ilxUnboxedPairRep repInt ilxMethTyVarA) "tryTakeMVar" [ty] [repMVar ilxMethTyVarA])
2188                   {-  MVar# s a -> State# s -> (# State# s, a #) -}
2189
2190         TryPutMVarOp -> ty2_op (\sty ty -> 
2191                 ilxCallSuppMeth repInt "tryPutMVar" [ty] [repMVar ilxMethTyVarA,ilxMethTyVarA])
2192                   {-  MVar# s a -> State# s -> (# State# s, a #) -}
2193
2194         PutMVarOp -> ty2_op (\sty ty -> 
2195                 ilxCallSuppMeth (ilxOp "void") "putMVar" [ty] [repMVar ilxMethTyVarA, ilxMethTyVarA])
2196                    {- MVar# s a -> a -> State# s -> State# s -}
2197
2198         SameMVarOp -> ty2_op (\sty ty -> ilxCeq)
2199                    {- MVar# s a -> MVar# s a -> Bool -}
2200
2201 --      TakeMaybeMVarOp -> ty2_op (\sty ty -> 
2202 --              (ilxCallSuppMeth (ilxUnboxedPairRep repInt ilxMethTyVarA) "tryTakeMVar" [ty] [repMVar ilxMethTyVarA]))
2203 --              {- MVar# s a -> State# s -> (# State# s, Int#, a #) -}
2204
2205         IsEmptyMVarOp -> ty2_op (\sty ty -> 
2206                 ilxCallSuppMeth repInt "isEmptyMVar" [ty] [repMVar ilxMethTyVarA])
2207                {- MVar# s a -> State# s -> (# State# s, Int# #) -}
2208
2209         TouchOp -> warn_op "touch" (ty1_op (\ty1 -> ilxOp "pop /* PrimOp touch */ "))
2210
2211                {- a -> Int# -}
2212         DataToTagOp -> ty1_op (\ty1 -> 
2213                 ilxCallSuppMeth repInt "dataToTag" [ty1] [ilxMethTyVarA])
2214                {- a -> Int# -}
2215
2216         TagToEnumOp -> ty1_op (\ty1 -> 
2217                 ilxCallSuppMeth ilxMethTyVarA "tagToEnum" [ty1] [repInt])
2218                {- Int# -> a -}
2219
2220         MakeStablePtrOp -> ty1_op (\ty1 -> ilxOpSeq [ilxOp "box", ty1, ilxOp "newobj void", repStablePtr {- ty1 -}, ilxOp "::.ctor(class [mscorlib]System.Object)"])
2221                  {-   a -> State# RealWorld -> (# State# RealWorld, StablePtr# a #) -}
2222         MakeStableNameOp -> ty1_op (\ty1 -> ilxOpSeq [ilxOp "pop newobj void", repStableName {- ty1 -}, ilxOp "::.ctor()"])
2223                         -- primOpInfo MakeStableNameOp = mkGenPrimOp SLIT("makeStableName#")  [alphaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed 2 [mkStatePrimTy realWorldTy, mkStableNamePrimTy alphaTy]))
2224
2225         EqStableNameOp -> ty1_op (\ty1 -> ilxOp "ceq")
2226                -- [alphaTyVar] [mkStableNamePrimTy alphaTy, mkStableNamePrimTy alphaTy] (intPrimTy)
2227         StableNameToIntOp -> warn_op "StableNameToIntOp" (ty1_op (\ty1 -> ilxOp "pop ldc.i4 0"))
2228                -- [alphaTyVar] [mkStableNamePrimTy alphaTy] (intPrimTy)
2229
2230         DeRefStablePtrOp -> ty1_op (\ty1 -> ilxOpSeq [ilxOp "ldfld class [mscorlib]System.Object", repStablePtr {- ty1 -}, ilxOp "::contents"])
2231                  {-  StablePtr# a -> State# RealWorld -> (# State# RealWorld, a #) -}
2232
2233         EqStablePtrOp -> ty1_op (\ty1 -> ilxOp "ceq")
2234                  {-  StablePtr# a -> StablePtr# a -> Int# -}
2235
2236             -- The 3rd argument to MkWeakOp is always a IO Monad action, i.e. passed as () --> ()
2237         MkWeakOp -> ty3_op (\ty1 ty2 ty3 ->  ilxCall (ilxMethodRef (repWeak ilxMethTyVarB) classWeak "bake" [ilxLift ty1,ilxLift ty2] [ilxMethTyVarA, ilxMethTyVarB, ilxLift (ilxTyIO ilxUnboxedEmptyRep)]))
2238                  {- o -> b -> c -> State# RealWorld -> (# State# RealWorld, Weak# b #) -}
2239
2240         DeRefWeakOp -> ty1_op (\ty1 ->  ilxCall (ilxMethodRef (ilxUnboxedPairRep repInt ilxMethTyVarA) classWeak "deref" [ty1] [repWeak ilxMethTyVarA]))
2241         FinalizeWeakOp -> ty1_op (\ty1 ->  ilxCall (ilxMethodRef (ilxUnboxedPairRep repInt (ilxTyIO ilxUnboxedEmptyRep)) classWeak "finalizer" [ty1] [repWeak ilxMethTyVarA]))
2242                    {-    Weak# a -> State# RealWorld -> (# State# RealWorld, Int#, 
2243         State# RealWorld -> (# State# RealWorld, Unit #)) #) -}
2244
2245         MkForeignObjOp -> simp_op (ilxOpSeq [ilxOp "newobj void", repForeign, ilxOp "::.ctor(void *)"])
2246         WriteForeignObjOp -> ty1_op (\sty -> ilxOpSeq [ilxOp "stfld void *", repForeign, ilxOp "::contents"])
2247         ForeignObjToAddrOp -> simp_op ilxAddrOfForeignOp
2248         YieldOp -> simp_op (ilxOpSeq [ilxOp "call class [mscorlib]System.Threading.Thread class [mscorlib]System.Threading.Thread::get_CurrentThread() 
2249                                 call instance void class [mscorlib]System.Threading.Thread::Suspend()"])
2250         MyThreadIdOp -> simp_op (ilxOpSeq [ilxOp "call default  class [mscorlib]System.Threading.Thread class [mscorlib]System.Threading.Thread::get_CurrentThread() "])
2251         -- This pushes a THUNK across as the exception value.
2252         -- This is the correct Haskell semantics...  TODO: we should probably
2253         -- push across an HaskellThreadAbortException object that wraps this
2254         -- thunk, but which is still actually an exception of
2255         -- an appropriate type.
2256         KillThreadOp -> ty1_op (\ty -> ilxOpSeq [ilxOp "call instance void class [mscorlib]System.Threading.Thread::Abort(class [mscorlib]System.Object) "])
2257               {-   ThreadId# -> a -> State# RealWorld -> State# RealWorld -}
2258
2259         ForkOp -> warn_op "ForkOp" (simp_op (ilxOp "/* ForkOp skipped... */ newobj void [mscorlib]System.Object::.ctor() throw"))
2260         ParOp ->  warn_op "ParOp" (simp_op (ilxOp "/* ParOp skipped... */ newobj void [mscorlib]System.Object::.ctor() throw"))
2261         DelayOp -> simp_op (ilxOp "call void class [mscorlib]System.Threading.Thread::Sleep(int32) ")
2262                  {-    Int# -> State# s -> State# s -}
2263
2264         WaitReadOp  -> warn_op "WaitReadOp" (simp_op (ilxOp "/* WaitReadOp skipped... */ pop"))
2265         WaitWriteOp -> warn_op "WaitWriteOp" (simp_op (ilxOp " /* WaitWriteOp skipped... */ newobj void [mscorlib]System.Object::.ctor() throw"))
2266         ParAtForNowOp -> warn_op "ParAtForNowOp" (simp_op (ilxOp " /* ParAtForNowOp skipped... */ newobj void [mscorlib]System.Object::.ctor() throw"))
2267         ParAtRelOp -> warn_op "ParAtRelOp" (simp_op (ilxOp " /* ParAtRelOp skipped... */ newobj void [mscorlib]System.Object::.ctor() throw"))
2268         ParAtAbsOp -> warn_op "ParAtAbsOp" (simp_op (ilxOp " /* ParAtAbsOp skipped... */ newobj void [mscorlib]System.Object::.ctor() throw"))
2269         ParAtOp -> warn_op "ParAtOp" (simp_op (ilxOp " /* ParAtOp skipped... */ newobj void [mscorlib]System.Object::.ctor() throw"))
2270         ParLocalOp -> warn_op "ParLocalOp" (simp_op (ilxOp " /* ParLocalOp skipped... */ newobj void [mscorlib]System.Object::.ctor() throw"))
2271         ParGlobalOp -> warn_op "ParGlobalOp" (simp_op (ilxOp " /* ParGlobalOp skipped... */ newobj void [mscorlib]System.Object::.ctor() throw"))
2272         SeqOp -> warn_op "SeqOp" (simp_op (ilxOp " newobj void [mscorlib]System.Object::.ctor() throw "))
2273         AddrToHValueOp -> warn_op "AddrToHValueOp" (simp_op (ilxOp "newobj void [mscorlib]System.Object::.ctor() throw"))
2274 --      ReallyUnsafePtrEqualityOp -> simp_op (ilxOp "ceq")
2275
2276         MkApUpd0_Op ->  warn_op "MkApUpd0_Op" (simp_op (ilxOp " newobj void [mscorlib]System.Object::.ctor() throw"))
2277         NewBCOOp ->  warn_op "NewBCOOp" (simp_op (ilxOp " newobj void [mscorlib]System.Object::.ctor() throw"))
2278                   -- ("newBCO#")  [alphaTyVar, deltaTyVar] [byteArrayPrimTy, byteArrayPrimTy, mkArrayPrimTy alphaTy, byteArrayPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed 2 [mkStatePrimTy deltaTy, bcoPrimTy]))
2279         _        -> pprPanic "Unimplemented primop" (ppr op)
2280
2281
2282 ty1_op :: (IlxTyFrag -> IlxOpFrag) -> [StgArg] ->  IlxOpFrag 
2283 ty1_op  op ((StgTypeArg ty1):rest)  = 
2284       ilxOpSeq [getArgsStartingAt 1 rest, 
2285                 op (ilxTypeR2 (deepIlxRepType ty1))]
2286
2287 ty2_op :: (IlxTyFrag -> IlxTyFrag -> IlxOpFrag) -> [StgArg] ->  IlxOpFrag 
2288 ty2_op  op ((StgTypeArg ty1):(StgTypeArg ty2):rest)  = 
2289       ilxOpSeq [getArgsStartingAt 2 rest, 
2290                 op (ilxTypeR2 (deepIlxRepType ty1)) 
2291                    (ilxTypeR2 (deepIlxRepType ty2))]
2292
2293 ty3_op :: (IlxTyFrag -> IlxTyFrag -> IlxTyFrag -> IlxOpFrag) -> [StgArg] ->  IlxOpFrag 
2294 ty3_op  op ((StgTypeArg ty1):(StgTypeArg ty2):(StgTypeArg ty3):rest) = 
2295       ilxOpSeq [getArgsStartingAt 3 rest, 
2296                 op (ilxTypeR2 (deepIlxRepType ty1)) 
2297                    (ilxTypeR2 (deepIlxRepType ty2))
2298                    (ilxTypeR2 (deepIlxRepType ty3))]
2299
2300 arg2_op :: (IlxTyFrag -> IlxOpFrag -> IlxOpFrag) -> [StgArg] ->  IlxOpFrag 
2301 arg2_op  op [a1, a2] = 
2302        op (getAsArg 1 a1)
2303           (getAsArg 2 a2)
2304
2305 ty1_arg2_op :: (IlxTyFrag -> IlxOpFrag ->  IlxOpFrag -> IlxOpFrag) -> [StgArg] ->  IlxOpFrag 
2306 ty1_arg2_op  op [(StgTypeArg ty1), a1, a2] = 
2307        op (ilxTypeR2 (deepIlxRepType ty1)) 
2308           (getAsArg 1 a1)
2309           (getAsArg 2 a2)
2310
2311 ty1_arg4_op :: (IlxTyFrag -> IlxOpFrag -> IlxOpFrag -> IlxOpFrag -> IlxOpFrag -> IlxOpFrag) -> [StgArg] ->  IlxOpFrag 
2312 ty1_arg4_op  op [(StgTypeArg ty1), a1, a2, a3, a4] = 
2313        op (ilxTypeR2 (deepIlxRepType ty1)) 
2314           (getAsArg 1 a1)
2315           (getAsArg 2 a2)
2316           (getAsArg 3 a3)
2317           (getAsArg 4 a4)
2318
2319 ty2_arg4_op :: (IlxTyFrag -> IlxTyFrag -> IlxOpFrag -> IlxOpFrag -> IlxOpFrag -> IlxOpFrag -> IlxOpFrag) -> [StgArg] ->  IlxOpFrag 
2320 ty2_arg4_op  op [(StgTypeArg ty1), (StgTypeArg ty2),a1, a2, a3, a4] = 
2321        op (ilxTypeR2 (deepIlxRepType ty1)) 
2322           (ilxTypeR2 (deepIlxRepType ty2)) 
2323           (getAsArg 2 a1)
2324           (getAsArg 3 a2)
2325           (getAsArg 4 a3)
2326           (getAsArg 5 a4)
2327
2328 hd (h:t) = h
2329
2330 getAsArg n a env = hd (ilxMapPlaceArgs n pushArg env [a])
2331 getArgsStartingAt n a env = vcat (ilxMapPlaceArgs n pushArg env a)
2332
2333 simp_op :: IlxOpFrag -> [StgArg] -> IlxOpFrag
2334 simp_op  op args env    = vcat (ilxMapPlaceArgs 0 pushArg env args) $$ op env
2335 warn_op  warning f args = trace ("WARNING! IlxGen cannot translate primop " ++ warning) (f args)
2336 \end{code}
2337
2338 %************************************************************************
2339 %*                                                                      *
2340 \subsection{C Calls}
2341 %*                                                                      *
2342 %************************************************************************
2343
2344 \begin{code}
2345 -- Call the P/Invoke stub wrapper generated in the import section.
2346 -- We eliminate voids in and around an IL C Call.  
2347 -- We also do some type-directed translation for pinning Haskell-managed blobs
2348 -- of data as we throw them across the boundary.
2349 ilxFCall env (CCall (CCallSpec (StaticTarget c) cconv gc)) args ret_ty
2350  = ilxComment ((text "C call") <+> pprCLabelString c) <+> 
2351         vcat [vcat (ilxMapPlaceArgs 0 pushCArg env args),
2352               text "call" <+> retdoc <+> pprCLabelString c <+> tyarg_doc
2353                     <+> pprCValArgTys ilxTypeL env (map deepIlxRepType (filter (not. isVoidIlxRepType) (map stgArgType tm_args))) ]
2354   where 
2355     retdoc | isVoidIlxRepType ret_ty = text "void"
2356            | otherwise               = ilxTypeR env (deepIlxRepType ret_ty)
2357     (ty_args,tm_args) = splitTyArgs1 args
2358     tyarg_doc | not (isEmptyVarSet (tyVarsOfTypes ty_args)) = text "/* type variable found */"
2359               | otherwise = pprTypeArgs ilxTypeR env ty_args
2360
2361 ilxFCall env (DNCall (DNCallSpec call_instr)) args ret_ty
2362   = ilxComment (text "IL call") <+> 
2363     vcat [vcat (ilxMapPlaceArgs 0 pushEvalArg env tm_args), 
2364           ptext call_instr
2365                 -- In due course we'll need to pass the type arguments
2366                 -- and to do that we'll need to have more than just a string
2367                 -- for call_instr
2368     ]
2369   where
2370     (ty_args,tm_args) = splitTyArgs1 args 
2371
2372 -- Push and argument and force its evaluation if necessary.
2373 pushEvalArg _ (StgTypeArg _) = empty
2374 pushEvalArg env (StgVarArg arg) = ilxFunApp env arg [] False
2375 pushEvalArg env (StgLitArg lit) = pushLit env lit
2376
2377
2378 hasTyCon (TyConApp tc _) tc2 = tc == tc2
2379 hasTyCon _  _ = False
2380
2381 isByteArrayCArgTy ty = hasTyCon ty byteArrayPrimTyCon || hasTyCon ty mutableByteArrayPrimTyCon
2382 isByteArrayCArg v = isByteArrayCArgTy (deepIlxRepType (idType v))
2383
2384 isForeignObjCArgTy ty = hasTyCon ty foreignObjPrimTyCon
2385 isForeignObjCArg v = isForeignObjCArgTy (deepIlxRepType (idType v))
2386
2387 pinCCallArg v = isByteArrayCArg v || isForeignObjCArg v  
2388
2389 pinCArg  env arg v = pushArg env arg <+> text "dup stloc" <+> singleQuotes (ilxEnvQualifyByExact env (ppr v) <> text "pin") 
2390 pushCArg  env arg@(StgVarArg v) | isByteArrayCArg v = pinCArg env arg v <+> ilxAddrOfByteArrOp env
2391 pushCArg env arg@(StgVarArg v) | isForeignObjCArg v = pinCArg env arg v <+> ilxAddrOfForeignOp env
2392 pushCArg env arg | otherwise = pushArg env arg
2393
2394 pprCValArgTys f env tys = parens (pprSepWithCommas (pprCValArgTy f env) tys)
2395 pprCValArgTy f env ty | isByteArrayCArgTy ty = text "void *" <+> ilxComment (text "interior pointer into ByteArr#")
2396 pprCValArgTy f env ty | isForeignObjCArgTy ty = text "void *" <+> ilxComment (text "foreign object")
2397 pprCValArgTy f env ty | otherwise = f env ty
2398
2399
2400 foldR            :: (a -> b -> b) -> [a] -> b -> b
2401 -- foldR _ [] z     =  z
2402 -- foldR f (x:xs) z =  f x (foldR f xs z) 
2403 {-# INLINE foldR #-}
2404 foldR k xs z = go xs
2405              where
2406                go []     = z
2407                go (y:ys) = y `k` go ys
2408
2409 \end{code}
2410