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