2 \section{Generate COM+ extended assembler}
5 module IlxGen( ilxGen ) where
7 #include "HsVersions.h"
9 import Char ( ord, chr )
11 import Id ( idType, idName, isDeadBinder, idPrimRep, idArityInfo )
12 import IdInfo ( arityLowerBound )
13 import Var ( Var, Id, TyVar, isId, isTyVar, tyVarKind, tyVarName )
15 import TyCon ( TyCon, tyConPrimRep, isUnboxedTupleTyCon, tyConDataCons, newTyConRep, tyConTyVars, isDataTyCon, isAlgTyCon )
16 import Class ( Class, classTyCon )
17 import Type ( isUnboxedTupleType, isUnLiftedType, isTyVarTy, mkTyVarTy, splitForAllTys, splitFunTys, applyTy, splitNewType_maybe, applyTys,typeKind,getTyVar )
18 import TypeRep ( Type(..), boxedKind,boxedTypeKind,openTypeKind,anyBoxKind, unboxedTypeKind )
19 import DataCon ( isUnboxedTupleCon, dataConTyCon, dataConRepType, dataConRepArgTys )
20 import Literal ( Literal(..), literalType )
21 import PrimOp ( PrimOp(..), CCallTarget(..),CCall(..) )
22 import PrimRep ( PrimRep(..) )
23 import Name ( nameModule, nameOccName, isGlobalName, isLocalName, isDllName, NamedThing(getName) )
24 import Unique -- Lots of keys
27 import Subst ( substTy, mkTyVarSubst )
28 import Module ( Module, PackageName, ModuleName, moduleName, modulePackageName, isLocalModule, pprModuleName, mkThisModule, mkSrcModule, mkPrelModule )
29 import CStrings ( CLabelString, pprCLabelString )
30 import TysWiredIn ( unboxedTupleTyCon, unboxedTupleCon, mkUnboxedTupleTy )
33 import List ( partition, elem, sortBy, insertBy,any )
35 import TysPrim ( byteArrayPrimTyCon, mutableByteArrayPrimTyCon )
36 -- opt_DoEtaReduction is used to help with assembly naming conventions for different
37 -- versions of compiled Haskell code. We add a ".O" to all assembly and module
38 -- names when this is set. One day this will be configured by the command line.
39 import CmdLineOpts ( opt_Static, opt_InPackage, opt_DoEtaReduction )
45 %************************************************************************
47 \subsection{Main driver}
49 %************************************************************************
52 ilxGen :: Module -> [TyCon] -> [Class] -> [(StgBinding,[Id])] -> SDoc
53 ilxGen mod tycons classes binds_w_srts
54 = vcat [vcat (map (ilxImportPackage topenv) (uniqSetToList import_packages)),
55 vcat (map (ilxImportModule topenv) (uniqSetToList import_modules)),
56 vcat (map (ilxImportTyCon topenv) (uniqSetToList import_tycons)),
57 vcat (map (ilxTyCon topenv) data_tycons),
58 vcat (map (ilxBindClosures topenv) binds),
59 ilxTopBind mod topenv toppairs
62 binds = map fst binds_w_srts
63 (import_packages,import_modules,import_tycons) = importsBinds binds `unionImpInfo` importsPrelude
64 toppairs = ilxPairs binds
65 topenv = extendIlxEnvWithTops (emptyIlxEnv False mod) mod toppairs
66 -- Generate info from class decls as well
67 data_tycons = filter isDataTyCon (tycons ++ map classTyCon classes)
70 %************************************************************************
72 \subsection{Find Imports}
74 %************************************************************************
78 importsBinds :: [StgBinding] -> ImportsInfo
79 importsBinds binds = unionImpInfos (map importsBind binds)
81 importsBind :: StgBinding -> ImportsInfo
82 importsBind (StgNonRec b rhs) = importsRhs rhs `unionImpInfo` importsVar b
83 importsBind (StgRec pairs) = unionImpInfos (map (\(b,rhs) -> importsRhs rhs `unionImpInfo` importsVar b) pairs)
85 importsRhs (StgRhsCon _ con args) = importsDataCon con `unionImpInfo` importsStgArgs args
86 importsRhs (StgRhsClosure _ _ srt _ upd args body) = importsExpr body `unionImpInfo` importsVars args
88 importsExpr :: StgExpr -> ImportsInfo
89 importsExpr (StgLit l) = emptyImpInfo
90 importsExpr (StgApp f args) = importsVar f `unionImpInfo` importsStgArgs args
91 importsExpr (StgConApp con args) = importsDataCon con `unionImpInfo` importsStgArgs args
92 importsExpr (StgPrimApp op args res_ty) = importsType res_ty `unionImpInfo` importsStgArgs args
93 importsExpr (StgSCC cc expr) = importsExpr expr
94 importsExpr (StgCase scrut _ _ bndr srt alts)
95 = importsExpr scrut `unionImpInfo` imports_alts alts `unionImpInfo` importsVar bndr
97 imports_alts (StgAlgAlts ty alts deflt)
98 = unionImpInfos (map imports_alg_alt alts) `unionImpInfo` imports_deflt deflt `unionImpInfo` importsType ty
100 imports_alg_alt (con, bndrs, _, rhs)
101 = importsExpr rhs `unionImpInfo` importsDataCon con `unionImpInfo` importsVars bndrs
103 imports_alts (StgPrimAlts ty alts deflt)
104 = unionImpInfos (map imports_prim_alt alts) `unionImpInfo` imports_deflt deflt `unionImpInfo` importsType ty
106 imports_prim_alt (lit, rhs) = importsExpr rhs
107 imports_deflt StgNoDefault = emptyImpInfo
108 imports_deflt (StgBindDefault rhs) = importsExpr rhs
110 importsExpr (StgLetNoEscape _ _ bind body) = importsExpr (StgLet bind body)
111 importsExpr (StgLet bind body)
112 = importsBind bind `unionImpInfo` importsExpr body
114 importsApp v args = importsVar v `unionImpInfo` importsStgArgs args
115 importsStgArgs args = unionImpInfos (map importsStgArg args)
117 importsStgArg :: StgArg -> ImportsInfo
118 importsStgArg (StgTypeArg ty) = importsType ty
119 importsStgArg (StgVarArg v) = importsVar v
120 importsStgArg _ = emptyImpInfo
122 importsVars vs = unionImpInfos (map importsVar vs)
123 importsVar v = importsName (idName v) `unionImpInfo` importsType (idType v)
126 | isLocalName n = emptyImpInfo
127 | thisModule == nameModule n = emptyImpInfo
128 | isDllName n = singlePackageImpInfo (modulePackageName (nameModule n))
129 | otherwise = singleModuleImpInfo (moduleName (nameModule n))
132 | thisModule == m = emptyImpInfo
133 | isLocalModule m = singleModuleImpInfo (moduleName m)
134 | otherwise = singlePackageImpInfo (modulePackageName m)
136 importsType :: Type -> ImportsInfo
137 importsType ty = importsType2 (deepIlxRepType ty)
139 importsType2 :: Type -> ImportsInfo
140 importsType2 (AppTy f x) = importsType2 f `unionImpInfo` importsType2 x
141 importsType2 (TyVarTy _) = emptyImpInfo
142 importsType2 (TyConApp tc args) =importsTyCon tc `unionImpInfo` importsTypeArgs2 args
143 importsType2 (FunTy arg res) = importsType arg `unionImpInfo` importsType2 res
144 importsType2 (ForAllTy tv body_ty) = importsType2 body_ty
145 importsType2 (NoteTy _ ty) = importsType2 ty
146 importsTypeArgs2 tys =unionImpInfos (map importsType2 tys)
148 importsDataCon dcon = importsTyCon (dataConTyCon dcon)
149 importsTyCon tc | (not (isDataTyCon tc) ||
150 isLocalName (getName tc) ||
151 thisModule == nameModule (getName tc)) = emptyImpInfo
152 importsTyCon tc | otherwise = importsName (getName tc) `unionImpInfo` (emptyUniqSet, emptyUniqSet,unitUniqSet tc)
155 if preludePackage == opt_InPackage then singleModuleImpInfo (mkSrcModule "PrelGHC")
156 else singlePackageImpInfo preludePackage
159 -- hack to get at Module.preludePackage - we should reveal it....
161 = if isLocalModule dummy then opt_InPackage else modulePackageName dummy
163 dummy = mkPrelModule (mkSrcModule "")
165 type ImportsInfo = (UniqSet PackageName, UniqSet ModuleName, UniqSet TyCon) -- (Packages, Modules, Datatypes)
167 emptyImpInfo :: ImportsInfo
168 emptyImpInfo = (emptyUniqSet, emptyUniqSet, emptyUniqSet)
169 singlePackageImpInfo p = (unitUniqSet p, emptyUniqSet, emptyUniqSet)
170 singleModuleImpInfo m = (emptyUniqSet, unitUniqSet m, emptyUniqSet)
172 unionImpInfo :: ImportsInfo -> ImportsInfo -> ImportsInfo
173 unionImpInfo (w1,x1,y1) (w2,x2,y2) = (unionUniqSets w1 w2, unionUniqSets x1 x2, unionUniqSets y1 y2)
175 unionImpInfos :: [ImportsInfo] -> ImportsInfo
176 unionImpInfos fvs = foldr unionImpInfo emptyImpInfo fvs
178 ilxImportTyCon :: IlxEnv -> TyCon -> SDoc
179 ilxImportTyCon env tycon | isDataTyCon tycon = pprIlxTyConDef True env tycon
180 ilxImportTyCon env tycon | otherwise = empty
182 ilxImportPackage :: IlxEnv -> PackageName -> SDoc
183 ilxImportPackage env p = text ".assembly extern ilx" <+> singleQuotes (text (_UNPK_ p) <> hscOptionQual) <+> text "{ }"
185 ilxImportModule :: IlxEnv -> ModuleName -> SDoc
186 ilxImportModule env m = text ".module extern ilx" <+> singleQuotes (ppr m <> hscOptionQual)
191 %************************************************************************
193 \subsection{Type declarations}
195 %************************************************************************
200 ilxTyCon :: IlxEnv -> TyCon -> SDoc
201 ilxTyCon env tycon = pprIlxTyConDef False env tycon
203 -- filter to get only dataTyCons?
204 pprIlxTyConDef importing env tycon =
206 text ".classunion" <+> (if importing then text "extern" else empty) <+> text "thunk"
207 <+> ((nameReference env (getName tycon)) <> (ppr tycon)) <+> tyvars_text <+> alts_text]
209 tyvars = tyConTyVars tycon
210 (ilx_tvs, non_ilx_tvs) = categorizeTyVars tyvars
211 alts_env = extendIlxEnvWithFormalTyVars env ilx_tvs
212 tyvars_text = pprTyVarBinders alts_env ilx_tvs
213 alts = vcat (map (pprIlxDataCon alts_env) (tyConDataCons tycon))
214 alts_text = nest 2 (braces alts)
216 pprIlxDataCon env dcon =
217 text ".alternative" <+> pprId dcon <+>
218 parens (pprSepWithCommas (pprIlxTypeL env) (map deepIlxRepType (filter (not. isVoidIlxRepType) (dataConRepArgTys dcon))))
222 %************************************************************************
224 \subsection{Getting the .closures and literals out} *
225 %************************************************************************
229 ilxBindClosures :: IlxEnv -> StgBinding -> SDoc
230 ilxBindClosures env (StgNonRec b rhs) = ilxRhsClosures env (b,rhs)
231 ilxBindClosures env (StgRec pairs)
232 = vcat (map (ilxRhsClosures new_env) pairs)
234 new_env = extendIlxEnvWithBinds env pairs
237 ilxRhsClosures env (bndr, StgRhsCon _ _ _)
240 ilxRhsClosures env (bndr, StgRhsClosure _ _ _ fvs upd args rhs)
241 = vcat [ilxExprClosures next_env rhs,
244 kind_text <+> squotes cloname <+> free_vs_text,
247 vcat [text ".apply" <+> closure_sig_text,
255 kind_of_thing = case upd of
256 Updatable -> ASSERT( null args ) ".thunk"
258 kind_text = text kind_of_thing
260 cloname = ilxEnvQualifyByModule env (ppr bndr)
261 next_env = ilxPlaceStgRhsClosure env bndr
262 (free_vs_text,env_with_fvs) = pprFreeBinders next_env fvs
269 text "-->" <+> rty_text]
271 (args_text,env_with_args) = pprArgBinders env_with_fvs args
273 -- Find the type returned, from the no. of args and the type of "bndr"
275 case retType env_with_fvs (idIlxRepType bndr) args of
276 Just (env,ty) -> pprIlxTypeR env ty
277 Nothing -> trace "WARNING! IlxGen.trace could not find return type - see generated ILX for context where this occurs." (text "// Could not find return type:" <+> pprIlxTypeR env_with_fvs (idIlxRepType bndr)<+> text ", non representation: " <+> pprIlxTypeR env_with_fvs (idType bndr))
279 -- strip off leading ForAll and Fun type constructions
280 -- up to the given number of arguments, extending the environment as
282 retType env ty [] = Just (env, ty)
283 retType env (ForAllTy tv ty) (arg:args) = retType (extendIlxEnvWithTyArgs env [tv]) ty args
284 retType env (FunTy l r) (arg:args) = retType env r args
285 retType _ _ _ = Nothing
287 -- Code for the local variables
288 locals = ilxExprLocals env_with_args rhs
290 env_with_locals = extendIlxEnvWithLocals env_with_args locals
292 -- Code for the body of the main apply method
293 body_code = vcat [empty,
294 pprIlxLocals env_with_args locals,
295 ilxExpr (IlxEEnv env_with_locals (mkUniqSet (filter (not.isTyVar) args))) rhs Return,
299 body_text = nest 2 (braces (text ".maxstack 100" <+> nest 2 body_code))
302 pprIlxLocals env [] = empty
304 = text ".locals" <+> parens (pprSepWithCommas (pprIlxLocal env) (filter nonVoidLocal vs))
306 nonVoidLocal (LocalId v,_) = not (isVoidIlxRepId v)
307 nonVoidLocal _ = True
309 pprIlxLocal env (LocalId v,_) = pprIlxTypeL env (idIlxRepType v) <+> pprId v
310 pprIlxLocal env (LocalSDoc (ty,doc,pin),_) = pprIlxTypeL env (deepIlxRepType ty) <+> (if pin then text "pinned" else empty) <+> doc
313 pprFreeBinders env fvs
314 = (ilx_tvs_text <+> vs_text, env2)
316 (free_ilx_tvs, free_non_ilx_tvs,free_vs) = categorizeVars fvs
317 real_free_vs = filter (not . isVoidIlxRepId) free_vs
318 -- ignore the higher order type parameters for the moment
319 env1 = extendIlxEnvWithFreeTyVars env free_ilx_tvs
320 ilx_tvs_text = pprTyVarBinders env1 free_ilx_tvs
321 vs_text = parens (pprSepWithCommas ppr_id real_free_vs)
322 ppr_id v = pprIlxTypeL env1 (idIlxRepType v) <+> pprId v
323 env2 = extendIlxEnvWithFreeVars env1 real_free_vs
325 pprIdBinder env v = parens (pprIlxTypeL env (idIlxRepType v) <+> pprId v)
327 -- Declarations for the arguments of the main apply method
328 pprArgBinders env [] = (empty,env)
329 pprArgBinders env (arg:args)
330 = (arg_text <+> rest_text, res_env)
332 (arg_text,env') = pprArgBinder env arg
333 (rest_text,res_env) = pprArgBinders env' args
335 -- We could probably omit some void argument binders, but
338 | isVoidIlxRepId arg = (text "()", extendIlxEnvWithArgs env [arg])
340 = if isTyVar arg then
341 let env' = extendIlxEnvWithTyArgs env [arg] in
342 (pprTyVarBinder env' arg, env')
343 else (pprIdBinder env arg,extendIlxEnvWithArgs env [arg])
346 -- Compute local variables used by generated method.
347 -- The names of some generated locals are recorded as SDocs.
349 data LocalSpec = LocalId Id | LocalSDoc (Type, SDoc, Bool) -- flag is for pinning
351 ilxExprLocals :: IlxEnv -> StgExpr -> [(LocalSpec,Maybe (IlxEnv,StgRhs))]
352 ilxExprLocals env (StgLet bind body) = ilxBindLocals env bind ++ ilxExprLocals env body
353 ilxExprLocals env (StgLetNoEscape _ _ bind body) = ilxBindLocals env bind ++ ilxExprLocals env body -- TO DO????
354 ilxExprLocals env (StgCase scrut _ _ bndr _ alts)
355 = ilxExprLocals (ilxPlaceStgCaseScrut env) scrut ++
356 (if isDeadBinder bndr then [] else [(LocalId bndr,Nothing)]) ++
357 ilxAltsLocals env alts
358 ilxExprLocals env (StgPrimApp (CCallOp (CCall (StaticTarget c) casm gc cconv)) args ret_ty)
359 = concat (ilxMapPlaceArgs 0 ilxCCallArgLocals env args)
360 ilxExprLocals _ _ = []
362 -- Generate locals to use for pinning arguments as we cross the boundary
364 ilxCCallArgLocals env arg@(StgVarArg v) | pinCCallArg v =
365 [(LocalSDoc (idType v, ilxEnvQualifyByExact env (ppr v) <> text "pin", True), Nothing)]
366 ilxCCallArgLocals _ _ | otherwise = []
368 ilxBindLocals env (StgNonRec b rhs) = [(LocalId b,Just (env, rhs))]
369 ilxBindLocals env (StgRec pairs) = map (\(x,y) -> (LocalId x,Just (env, y))) pairs
371 ilxAltsLocals env (StgAlgAlts _ alts deflt) = ilxDefltLocals env deflt ++ concat (ilxMapPlaceAlts ilxAlgAltLocals env alts)
372 ilxAltsLocals env (StgPrimAlts _ alts deflt) = ilxDefltLocals env deflt ++ concat (ilxMapPlaceAlts ilxPrimAltLocals env alts)
374 ilxAlgAltLocals env (con, bndrs, _, rhs) = map (\x -> (LocalId x,Nothing)) (filter (\v -> isId v && not (isDeadBinder v)) bndrs) ++ ilxExprLocals env rhs
375 ilxPrimAltLocals env (lit, rhs) = ilxExprLocals env rhs
377 ilxDefltLocals env StgNoDefault = []
378 ilxDefltLocals env (StgBindDefault rhs) = ilxExprLocals (ilxPlaceStgBindDefault env) rhs
381 ilxExprClosures :: IlxEnv -> StgExpr -> SDoc
382 ilxExprClosures env (StgApp _ args)
383 = vcat (ilxMapPlaceArgs 0 (ilxArgClosures) env args) -- get strings
384 ilxExprClosures env (StgConApp _ args)
385 = vcat (ilxMapPlaceArgs 0 (ilxArgClosures) env args) -- get strings
386 ilxExprClosures env (StgPrimApp _ args _)
387 = vcat (ilxMapPlaceArgs 0 (ilxArgClosures) env args) -- get strings
388 ilxExprClosures env (StgLet bind body)
389 = ilxBindClosures env bind $$ ilxExprClosures (extendIlxEnvWithBinds env (ilxPairs1 bind)) body
390 ilxExprClosures env (StgLetNoEscape _ _ bind body) -- TO DO????
391 = ilxBindClosures env bind $$ ilxExprClosures (extendIlxEnvWithBinds env (ilxPairs1 bind)) body
392 ilxExprClosures env (StgCase scrut _ _ _ _ alts)
393 = ilxExprClosures (ilxPlaceStgCaseScrut env) scrut $$ ilxAltsClosures env alts
394 ilxExprClosures env (StgLit lit)
396 ilxExprClosures env other
399 ilxAltsClosures env (StgAlgAlts _ alts deflt)
400 = vcat [ilxExprClosures (ilxPlaceAlt env i) rhs | (i,(_, _, _, rhs)) <- [1..] `zip` alts]
402 ilxDefltClosures env deflt
404 ilxAltsClosures env (StgPrimAlts _ alts deflt)
405 = vcat [ilxExprClosures (ilxPlaceAlt env i) rhs | (i,(_, rhs)) <- [1..] `zip` alts]
407 vcat [ ilxGenLit (ilxPlacePrimAltLit env i) lit | (i,(lit,_)) <- [1..] `zip` alts]
409 ilxDefltClosures env deflt
411 ilxDefltClosures env (StgBindDefault rhs) = ilxExprClosures (ilxPlaceStgBindDefault env) rhs
412 ilxDefltClosures env StgNoDefault = empty
414 ilxArgClosures env (StgLitArg lit) = ilxGenLit env lit
415 ilxArgClosures _ _ = empty
419 ilxGenLit env (MachStr fs)
420 = vcat [text ".field static assembly char " <+> squotes nm <+> text "at" <+> nm <> text "L",
421 text ".data" <+> nm <> text "L" <+> text "= char *(" <> pprFSInILStyle fs <> text ")"
424 nm = ilxEnvQualifyByExact env (text "string")
426 ilxGenLit _ _ = empty
431 %************************************************************************
433 \subsection{Generating code}
435 %************************************************************************
440 -- Environment when generating expressions
441 data IlxEEnv = IlxEEnv IlxEnv (UniqSet Id)
443 data Sequel = Return | Jump IlxLabel
445 ilxSequel Return = text "ret"
446 ilxSequel (Jump lbl) = text "br" <+> pprIlxLabel lbl
448 isReturn Return = True
449 isReturn (Jump _) = False
452 ilxExpr :: IlxEEnv -> StgExpr
453 -> Sequel -- What to do at the end
456 ilxExpr eenv@(IlxEEnv env _) (StgApp fun args) sequel
457 = ilxFunApp env fun args (isReturn sequel) $$ ilxSequel sequel
459 -- ilxExpr eenv (StgLit lit) sequel
460 ilxExpr eenv@(IlxEEnv env _) (StgLit lit) sequel
461 = pushLit env lit $$ ilxSequel sequel
463 -- ilxExpr eenv (StgConApp data_con args) sequel
464 ilxExpr eenv@(IlxEEnv env _) (StgConApp data_con args) sequel
465 = text " /* ilxExpr:StgConApp */ " <+> ilxConApp env data_con args $$ ilxSequel sequel
467 -- ilxExpr eenv (StgPrimApp primop args _) sequel
468 ilxExpr eenv@(IlxEEnv env _) (StgPrimApp primop args ret_ty) sequel
469 = ilxPrimApp env primop args ret_ty $$ ilxSequel sequel
472 -- The following are versions of a peephole optimizations for "let t = \[] t2[fvs] in t"
473 -- I think would be subsumed by a general treatmenet of let-no-rec bindings??
474 ilxExpr eenv@(IlxEEnv env _) (StgLet (StgNonRec bndr (StgRhsClosure _ _ _ fvs upd [] rhs)) (StgApp fun [])) sequel
475 | (bndr == fun && null (ilxExprLocals env rhs)) -- TO DO???
476 = ilxExpr eenv rhs sequel
477 ilxExpr eenv@(IlxEEnv env _) (StgLetNoEscape _ _ (StgNonRec bndr (StgRhsClosure _ _ _ fvs upd [] rhs)) (StgApp fun [])) sequel
478 | (bndr == fun && null (ilxExprLocals env rhs)) -- TO DO???
479 = ilxExpr eenv rhs sequel
482 ilxExpr eenv (StgLet bind body) sequel
483 = ilxBind eenv bind $$ ilxExpr eenv body sequel
486 ilxExpr eenv (StgLetNoEscape _ _ bind body) sequel -- TO DO???
487 = ilxBind eenv bind $$ ilxExpr eenv body sequel
489 -- StgCase: Special case 1 to avoid spurious branch.
490 ilxExpr eenv@(IlxEEnv env live) (StgCase (StgApp fun args) live_in_case live_in_alts bndr _ alts) sequel
491 = vcat [ilxWipe env (uniqSetToList (live `minusUniqSet` live_in_case)),
492 ilxFunApp (ilxPlaceStgCaseScrut env) fun args False,
493 --ilxWipe env (uniqSetToList (live_in_case `minusUniqSet` live_in_alts)),
494 --ilxAlts (IlxEEnv env live_in_alts) bndr alts sequel
495 ilxAlts (IlxEEnv env live_in_case) bndr alts sequel
498 -- StgCase: Special case 2 to avoid spurious branch.
499 ilxExpr eenv@(IlxEEnv env live) (StgCase (StgPrimApp primop args ret_ty) live_in_case live_in_alts bndr _ alts) sequel
500 = vcat [ilxWipe env (uniqSetToList (live `minusUniqSet` live_in_case)),
501 ilxPrimApp (ilxPlaceStgCaseScrut env) primop args ret_ty,
502 --ilxWipe env (uniqSetToList (live_in_case `minusUniqSet` live_in_alts)),
503 --ilxAlts (IlxEEnv env live_in_alts) bndr alts sequel
504 ilxAlts (IlxEEnv env live_in_case) bndr alts sequel
507 -- StgCase: Normal case.
508 ilxExpr eenv@(IlxEEnv env live) (StgCase scrut live_in_case live_in_alts bndr _ alts) sequel
509 = vcat [ilxWipe env (uniqSetToList (live `minusUniqSet` live_in_case)),
510 ilxExpr (IlxEEnv (ilxPlaceStgCaseScrut env) live_in_case) scrut (Jump join_lbl),
512 --ilxWipe env (uniqSetToList (live_in_case `minusUniqSet` live_in_alts)),
513 --ilxAlts (IlxEEnv env live_in_alts) bndr alts sequel
514 ilxAlts (IlxEEnv env live_in_case) bndr alts sequel
517 join_lbl = mkJoinLabel bndr
519 -- Wipe out locals and arguments that are no longer in use, to
520 -- prevent space leaks. If the VM is implemented 100% correctly then
521 -- this should probably not be needed, as the live variable analysis
522 -- in the JIT would tell the GC that these locals and arguments are
523 -- no longer live. However I'm putting it in here so we can
524 -- check out if it helps.
526 -- Also, in any case this doesn't capture everything we need. e.g.
527 -- when making a call:
529 -- where x is not used in the alternatives, then the variable x
530 -- is no longer live from the point it is transferred to the call
531 -- onwards. We should expunge "live_in_case - live_in_alts" right
532 -- before making the call, not after returning from the call....
534 -- Strictly speaking we also don't need to do this for primitive
535 -- values such as integers and addresses, i.e. things not
536 -- mapped down to GC'able objects.
538 = vcat (map (ilxWipeOne env) (filter (not.isVoidIlxRepId) ids))
541 = case lookupIlxVarEnv env id of
542 Just Local -> text "ldloca " <+> pprId id <+> text "initobj" <+> (pprIlxTypeL env (idIlxRepType id))
543 Just Arg -> text "deadarg " <+> pprId id <+> text "," <+> (pprIlxTypeL env (idIlxRepType id))
544 Just (CloVar _) -> ilxComment (text "not yet wiping closure variable" <+> pprId id )
545 _ -> ilxComment (text "cannot wipe non-local/non-argument" <+> pprId id )
549 ----------------------
551 ilxAlts :: IlxEEnv -> Id -> StgCaseAlts -> Sequel -> SDoc
552 ilxAlts eenv@(IlxEEnv env live) bndr alts sequel
553 -- At the join label, the result is on top
555 = vcat [store_in_bndr,
556 do_case_analysis alts
559 store_in_bndr | isDeadBinder bndr = empty
560 | isVoidIlxRepId bndr
561 = ilxComment (text "ignoring store of zero-rep value to be analyzed")
562 | otherwise = text "dup" $$ (text "stloc" <+> pprId bndr)
564 do_case_analysis (StgAlgAlts _ [] deflt)
567 do_case_analysis (StgAlgAlts ty args deflt)
568 = do_alg_alts (deepIlxRepType ty) ([1..] `zip` args) deflt
570 do_case_analysis (StgPrimAlts ty alts deflt)
571 = do_prim_alts ([1..] `zip` alts) $$ do_deflt deflt
573 do_alg_alts ty [(i, alt@(data_con,bndrs,used_flags, rhs))] StgNoDefault | isUnboxedTupleCon data_con
574 -- Collapse the analysis of unboxed tuples where
575 -- some or all elements are zero-sized
577 -- TO DO: add bndrs to set of live variables
579 [h] -> bind_collapse bndrs used_flags <+> do_rhs_no_pop alt_env rhs
580 _ -> bind_components alt_env ty dcon' bndrs 0 used_flags <+> do_rhs alt_env rhs
582 bndrs' = filter (not. isVoidIlxRepId) bndrs
583 -- Replacement unboxed tuple type constructor, used if any of the
584 -- arguments have zero-size and more than one remains.
585 dcon' = unboxedTupleCon (length bndrs')
587 alt_env = IlxEEnv (ilxPlaceAlt env i) live
588 --alt_env = IlxEEnv (ilxPlaceAlt env i)
590 bind_collapse [] _ = panic "bind_collapse: unary element not found"
591 bind_collapse (h:t) (is_used:used_flags)
592 | isVoidIlxRepId h = ilxComment (text "zero-rep binding eliminated") <+> (bind_collapse t used_flags)
593 | not is_used = ilxComment (text "not used") <+> text "pop"
594 | otherwise = text "stloc" <+> pprId h
597 do_alg_alts ty [(i, alt@(data_con,bndrs,used_flags, rhs))] StgNoDefault
598 = vcat [text "castdata" <+> sep [pprIlxTypeR env ty <> comma,
599 ilxConRef env data_con],
600 do_alg_alt (IlxEEnv (ilxPlaceAlt env i) live) ty alt
603 do_alg_alts ty alts deflt
604 = vcat [text "datacase" <+> sep [pprIlxTypeR env ty,text ",",
605 pprSepWithCommas pp_case labels_w_alts],
607 vcat (map (do_labelled_alg_alt ty) labels_w_alts)
610 pp_case (i, (lbl, (data_con, _, _, _))) = parens (ilxConRef env data_con <> comma <> pprIlxLabel lbl)
611 labels_w_alts = [(i,(mkAltLabel bndr i, alt)) | (i, alt) <- alts]
613 do_prim_alts [] = empty
614 do_prim_alts ((i, (lit,alt)) : alts)
615 = vcat [text "dup", pushLit (ilxPlacePrimAltLit env i) lit, text "bne.un" <+> pprIlxLabel lbl,
616 do_rhs (IlxEEnv (ilxPlaceAlt env i) live) alt,
617 ilxLabel lbl, do_prim_alts alts]
619 lbl = mkAltLabel bndr i
621 do_labelled_alg_alt ty (i,(lbl, alt))
622 = ilxLabel lbl $$ do_alg_alt (IlxEEnv (ilxPlaceAlt env i) live) ty alt
624 do_alg_alt alt_eenv ty (data_con, bndrs, used_flags, rhs)
625 = vcat [bind_components alt_eenv ty data_con bndrs 0 used_flags,
629 bind_components alt_eenv ty data_con [] n _ = empty
630 bind_components alt_eenv ty data_con (h:t) n (is_used:used_flags)
632 -- don't increase the count in this case
633 = ilxComment (text "zero-rep binding eliminated")
634 <+> bind_components alt_eenv ty data_con t n used_flags
636 = bind_component alt_eenv ty data_con h is_used n
637 <+> bind_components alt_eenv ty data_con t (n + 1) used_flags
639 bind_component alt_eenv@(IlxEEnv alt_env _) ty data_con bndr is_used reduced_fld_no
641 = ilxComment (text "not used")
642 | isVoidIlxRepId bndr
643 = ilxComment (text "ignoring bind of zero-rep variable")
644 | otherwise = vcat [text "dup",
645 ld_data alt_env ty data_con reduced_fld_no bndr,
646 text "stloc" <+> pprId bndr]
648 do_deflt (StgBindDefault rhs) = do_rhs (IlxEEnv (ilxPlaceStgBindDefault env) live) rhs
649 do_deflt StgNoDefault = empty
652 | isVoidIlxRepId bndr = do_rhs_no_pop alt_eenv rhs -- void on the stack, nothing to pop
653 | otherwise = text "pop" $$ do_rhs_no_pop alt_eenv rhs -- drop the value
655 do_rhs_no_pop alt_env rhs = ilxExpr alt_env rhs sequel
657 ld_data alt_env ty data_con reduced_fld_no bndr
658 | isUnboxedTupleCon data_con
659 = text "ldfld" <+> text "!" <> integer reduced_fld_no <+> pprIlxTypeR alt_env ty <> text "::fld" <> integer reduced_fld_no
661 = text "lddata" <+> sep [pprIlxTypeR alt_env ty <> comma,
662 ilxConRef env data_con <> comma,
663 integer reduced_fld_no]
666 -------------------------
672 -- Constants of unlifted types are represented as
673 -- applications to no arguments.
674 ilxFunApp env fun [] _ | isUnLiftedType (idType fun)
677 ilxFunApp env fun args tail_call
679 -- ldloc f function of type forall a. a->a
680 -- ldloc x arg of type Int
681 -- .tail callfunc <Int32> (!0) --> !0
683 vcat [pushId env fun,ilxFunAppArgs env 0 (idIlxRepType fun) args tail_call known_clo]
686 case lookupIlxBindEnv env fun of
687 Just (place, StgRhsClosure _ _ _ _ Updatable _ _) -> Nothing
688 Just (place, StgRhsClosure _ _ _ fvs _ args _) -> Just (place,fun,args,fvs)
689 _ -> trace (show fun ++ " --> " ++ show (arityLowerBound (idArityInfo fun))) Nothing
691 -- Push as many arguments as ILX allows us to in one go.
692 -- Recurse until we're done.
693 ilxFunAppArgs env num_sofar funty args tail_call known_clo
694 = vcat [vcat (ilxMapPlaceArgs num_sofar pushArgWithVoids env now_args),
695 call_instr <+> now_args_text
697 <+> (pprIlxTypeR env_after_now_tyvs later_ty),
701 now_args_text = hsep (map (pprIlxArgInfo env_after_now_tyvs) now_arg_tys)
703 (now_args,now_arg_tys,env_after_now_tyvs,later_args,later_ty) =
705 (StgTypeArg v:rest) -> get_type_args ilxBestTypeArity args env funty
706 _ -> get_term_args ilxBestTermArity args env funty
708 -- Only apply up to maxArity real (non-type) arguments
709 -- at a time. ILX should, in principle, allow us to apply
710 -- arbitrary numbers, but you will get more succinct
711 -- (and perhaps more efficient) IL code
712 -- if you apply in clumps according to its maxArity setting.
713 -- This is because it has to unwind the stack and store it away
714 -- in local variables to do the partial applications.
716 -- Similarly, ILX only allows one type application at a time, at
717 -- least until we implement unwinding the stack for this case.
719 -- NB: In the future we may have to be more careful
720 -- all the way through
721 -- this file to bind type variables as we move through
722 -- type abstractions and "forall" types. This would apply
723 -- especially if the type variables were ever bound by expressions
724 -- involving the type variables.
726 -- This part strips off at most "max" term applications or one type application
727 get_type_args 0 args env funty = ([],[],env,args,funty)
728 get_type_args max args env (NoteTy _ ty) =
729 trace "IlxGen Internal Error: non representation type passed to get_args" (get_type_args max args env ty)
730 get_type_args max ((arg@(StgTypeArg v)):rest) env (ForAllTy tv rem_funty)
731 = if isIlxTyVar tv then
732 let env2 = extendIlxEnvWithFormalTyVars env [tv] in
733 let rest_ty = deepIlxRepType (substTy (mkTyVarSubst [tv] [v]) rem_funty) in
734 let (now,now_tys,env3,later,later_ty) = get_type_args (max - 1) rest env rest_ty in
735 let arg_ty = mkTyVarTy tv in
736 (arg:now,(arg,arg_ty):now_tys,env2, later, later_ty)
738 get_type_args max rest env rem_funty -- ? subst??
739 get_type_args _ (StgTypeArg _:_) _ _ = trace "IlxGen Internal Error: get_type_args could not get ForAllTy for corresponding arg" ([],[],env,[],funty)
740 get_type_args _ args env funty = ([],[],env,args,funty)
742 -- We could probably skip some void-rep arguments. Instead we
743 -- emit "ldvoid" for these and let ILXASM optimize them away.
744 -- get_term_args max (h@(StgVarArg v):t) env (FunTy dom ran) | isVoidIlxRepId v
745 -- = get_term_args max t env ran
746 get_term_args max args env (NoteTy _ ty) =
748 trace "IlxGen Internal Error: non representation type passed to get_term_args" (get_term_args max args env ty)
749 get_term_args 0 args env funty = ([],[],env,args,funty)
751 get_term_args _ (args@(StgTypeArg _:_)) env funty = ([],[],env,args,funty)
752 get_term_args max (h:t) env (FunTy dom ran) =
753 let (now,now_tys,env2,later,later_ty) = get_term_args (max - 1) t env ran in
754 (h:now, (h,dom):now_tys,env2,later,later_ty)
755 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)
756 get_term_args max args env funty = ([],[],env,args,funty)
758 -- Are there any remaining arguments?
759 done = case later_args of
763 -- If so, generate the subsequent calls.
764 later = if done then text "// done"
765 else ilxFunAppArgs env (num_sofar + length now_args) later_ty later_args tail_call Nothing
767 -- Work out whether to issue a direct call a known closure (callclo) or
768 -- an indirect call (callfunc). Basically, see if the identifier has
769 -- been let-bound, and then check we are applying exactly the right
770 -- number of arguments. Also check that it's not a thunk (actually, this
771 -- is done up above).
773 -- The nasty "all" check makes sure that
774 -- the set of type variables in scope at the callsite is a superset
775 -- of the set of type variables needed for the direct call. This is
776 -- is needed because not all of the type variables captured by a
777 -- let-bound binding will get propogated down to the callsite, and
778 -- the ILX system of polymorphism demands that the free type variables
779 -- get reapplied when we issue the direct "callclo". The
780 -- type variables are in reality also "bound up" in the closure that is
781 -- passed as the first argument, so when we do an indirect call
782 -- to that closure we're fine, which is why we don't need them in
783 -- the "callfunc" case.
786 Just (known_env,fun,needed,fvs) | (length needed == length args) &&
787 all (\x -> elemIlxTyVarEnv x env) free_ilx_tvs ->
788 vcat [text "callclo class",
789 nameReference env (idName fun) <+> squotes (ilxEnvQualifyByModule env (ppr fun)),
790 pprTypeArgs pprIlxTypeR env (map mkTyVarTy free_ilx_tvs)]
793 (free_ilx_tvs, free_non_ilx_tvs,free_vs) = categorizeVars fvs
794 otherwise -> text "callfunc"
796 if (tail_call && done) then text "tail." <+> basic_call_instr
797 else basic_call_instr
800 --------------------------
801 -- Print the arg info at the call site
802 -- For type args we are, at the moment, required to
803 -- give both the actual and the formal (bound). The formal
804 -- bound is always System.Object at the moment (bounds are
805 -- not properly implemented in ILXASM in any case, and nor do
806 -- we plan on making use og them) For
807 -- non-type args the actuals are on the stack, and we just give the
809 pprIlxArgInfo env (StgTypeArg arg,ty) =
810 angleBrackets (pprIlxTypeR env (deepIlxRepType arg) <+> ilxComment (text "actual for tyvar")) <+> text "<class [mscorlib] System.Object>"
811 pprIlxArgInfo env (_,ty) =
812 parens (pprIlxTypeL env ty)
815 ----------------------------
816 -- Code for a binding
817 ilxBind :: IlxEEnv -> StgBinding -> SDoc
818 ilxBind eenv@(IlxEEnv env _) bind =
819 vcat [vcat (map (ilxRhs env rec) pairs),
820 vcat (map (ilxFixupRec env rec) pairs)]
822 rec = ilxRecIds1 bind
823 pairs = ilxPairs1 bind
826 ----------------------------
827 -- Allocate a closure or constructor. Fix up recursive definitions.
828 ilxRhs :: IlxEnv -> [Id] -> (Id, StgRhs) -> SDoc
830 ilxRhs env rec (bndr, _) | isVoidIlxRepId bndr
833 ilxRhs env rec (bndr, StgRhsCon _ con args)
834 = vcat [text " /* ilxRhs:StgRhsCon */ " <+> ilxConApp env con args,
835 text "stloc" <+> pprId bndr
838 ilxRhs env rec (bndr, StgRhsClosure _ _ _ fvs upd args rhs)
839 = -- Assume .closure v<any A>(int64,!A) {
840 -- .apply <any B> (int32) (B) { ... }
843 -- let v = \B (x:int32) (y:B). ...
845 -- newclo v<int32>(int64,!0)
847 vcat [vcat (map pushFv free_vs),
848 (if null free_non_ilx_tvs then empty else (ilxComment (text "ignored some higher order type arguments in application - code will be non-verifiable"))),
849 text "newclo" <+> clotext,
850 text "stloc" <+> pprId bndr
853 pushFv id = if elem id rec then text "ldnull" else pushId env id
854 (free_ilx_tvs, free_non_ilx_tvs,free_vs) = categorizeVars fvs
855 clotext = pprIlxBoxedTyConApp env (ilxEnvQualifyByModule env (ppr bndr)) (map mkTyVarTy free_ilx_tvs)
857 ilxFixupRec env rec (bndr, _) | isVoidIlxRepId bndr = ilxComment (text "no recursive fixup for void-rep-id")
859 ilxFixupRec env rec (bndr, StgRhsCon _ con args)
860 = text "// no recursive fixup"
862 ilxFixupRec env rec (bndr, StgRhsClosure _ _ _ fvs upd args rhs)
863 = vcat [vcat (map fixFv rec)]
865 fixFv recid = if elem recid fvs then
866 vcat [pushId env bndr,
868 text "stclofld" <+> clotext <> text "," <+> pprId recid]
869 else text "//no fixup needed for" <+> pprId recid
870 (free_ilx_tvs, free_non_ilx_tvs,free_vs) = categorizeVars fvs
871 clotext = pprIlxBoxedTyConApp env (ilxEnvQualifyByModule env (ppr bndr)) (map mkTyVarTy free_ilx_tvs)
875 ---------------------------------------------
876 -- Code for a top-level binding in a module
877 ilxPairs binds = concat (map ilxPairs1 binds)
879 ilxPairs1 (StgNonRec bndr rhs) = [(bndr,rhs)]
880 ilxPairs1 (StgRec pairs) = pairs
882 ilxRecIds1 (StgNonRec bndr rhs) = []
883 ilxRecIds1 (StgRec pairs) = map fst pairs
885 ---------------------------------------------
886 -- Code for a top-level binding in a module
887 -- TODO: fix up recursions amongst CAF's
892 -- For the moment I've put in a completely spurious "reverse"...
894 -- Consider: make fixing up of CAF's part of ILX? i.e.
895 -- put static, constant, allocated datastructures into ILX.
897 stableSortBy :: (a -> a -> Ordering) -> [a] -> [a]
898 stableSortBy f (h:t) = insertBy f h (stableSortBy f t)
899 stableSortBy f [] = []
901 usedBy :: (Id,StgRhs) -> (Id,StgRhs) -> Ordering
902 usedBy (m,_) (_,StgRhsCon _ data_con args) | any (isArg m) args = LT
903 usedBy (m,_) (n,_) | m == n = EQ
904 usedBy (m,_) (_,_) = GT
906 isArg m (StgVarArg n) = (n == m)
910 ilxTopBind :: Module -> IlxEnv -> [(Id,StgRhs)] -> SDoc
911 --ilxTopBind mod env (StgNonRec bndr rhs) =
912 --ilxTopRhs env (bndr,rhs)
913 ilxTopBind mod env pairs =
914 vcat [text ".class" <+> pprId mod,
915 nest 2 (braces (nest 2 (vcat [empty,cctor, flds, empty])))]
917 cctor = vcat [text ".method static rtspecialname specialname void .cctor()",
919 (nest 2 (vcat [text ".maxstack 100",
920 text "ldstr \"LOG: initializing module" <+> pprId mod <+> text "\" call void ['mscorlib']System.Console::WriteLine(class [mscorlib]System.String)",
921 vcat (map (ilxTopRhs mod env) (stableSortBy usedBy pairs)),
922 text "ldstr \"LOG: initialized module" <+> pprId mod <+> text "\" call void ['mscorlib']System.Console::WriteLine(class [mscorlib]System.String)",
925 flds = vcat (map (ilxTopRhsStorage mod env) pairs)
927 --ilxTopRhs mod env (bndr, _) | isVoidIlxRepId bndr
930 ilxTopRhs mod env (bndr, StgRhsClosure _ _ _ fvs upd args rhs)
931 = vcat [vcat (map (pushId env) free_vs),
932 (if null free_non_ilx_tvs then empty else (ilxComment (text "ignored some higher order type arguments in application - code will be non verifiable...."))),
933 text "newclo" <+> pprIlxBoxedTyConApp env (ilxEnvQualifyByModule env (ppr bndr)) (map mkTyVarTy free_ilx_tvs),
934 text "stsfld" <+> pprFieldRef env (mod,bndTy,bndr)
937 (free_ilx_tvs, free_non_ilx_tvs,free_vs) = categorizeVars fvs
938 bndTy = idIlxRepType bndr
940 ilxTopRhs mod env (bndr, StgRhsCon _ data_con args)
941 = vcat [ text " /* ilxTopRhs: StgRhsCon */ " <+> ilxConApp env data_con args,
942 text "stsfld" <+> pprFieldRef env (mod,bndTy,bndr)
945 bndTy = idIlxRepType bndr
947 pprFieldRef env (mod,ty,id)
948 = pprIlxTypeL env ty <+> moduleReference env mod <+> pprId mod <> text "::" <> pprId id
950 ilxTopRhsStorage mod env (bndr, StgRhsClosure _ _ _ _ _ _ _)
951 = text ".field public static " <+> pprIlxTypeL env bndTy <+> pprId bndr
953 bndTy = idIlxRepType bndr
954 ilxTopRhsStorage mod env (bndr, StgRhsCon _ _ _)
955 = text ".field public static " <+> pprIlxTypeL env bndTy <+> pprId bndr
957 bndTy = idIlxRepType bndr
959 --------------------------------------
961 pushArgWithVoids = pushArg_aux True
962 pushArg = pushArg_aux False
964 pushArg_aux voids env (StgTypeArg ty) = empty
965 pushArg_aux voids env (StgVarArg var) = pushId_aux voids env var
966 pushArg_aux voids env (StgLitArg lit) = pushLit env lit
969 mapi f l = mapi_aux f l 0
972 mapi_aux f (h:t) n = f n h : mapi_aux f t (n+1)
974 --------------------------------------
976 pushId = pushId_aux False
978 pushId_aux :: Bool -> IlxEnv -> Id -> SDoc
979 pushId_aux voids _ id | isVoidIlxRepId id =
980 if voids then text "ldvoid" else ilxComment (text "pushId: void rep skipped")
982 = case lookupIlxVarEnv env var of
983 Just Arg -> text "ldarg" <+> pprId var
984 Just (CloVar n) -> text "ldenv" <+> int n
985 Just Local -> text "ldloc" <+> pprId var
987 vcat [ilxComment (text "pushId (Top) " <+> pprId m),
988 text "ldsfld" <+> pprIlxTypeL env (idIlxRepType var)
989 <+> moduleReference env m <+> pprId (moduleName m) <> text "::" <> pprId var]
992 vcat [ilxComment (text "pushId (import) " <+> pprIlxTopVar env var),
993 text "ldsfld" <+> pprIlxTypeL env (idIlxRepType var)
994 <+> pprIlxTopVar env var]
996 --------------------------------------
998 pushLit env (MachChar c) = text "ldc.i4" <+> int (ord c)
999 pushLit env (MachStr s) = text "ldsflda char " <+> ilxEnvQualifyByExact env (text "string") -- pprFSInILStyle s
1000 pushLit env (MachInt i) = text "ldc.i4" <+> integer i
1001 pushLit env (MachInt64 i) = text "ldc.i8" <+> integer i
1002 pushLit env (MachWord w) = text "ldc.i4" <+> integer w <+> text "conv.u4"
1003 pushLit env (MachWord64 w) = text "ldc.i8" <+> integer w <+> text "conv.u8"
1004 pushLit env (MachFloat f) = text "ldc.r4" <+> rational f
1005 pushLit env (MachDouble f) = text "ldc.r8" <+> rational f
1006 pushLit env (MachLitLit _ _) = trace "WARNING: Cannot compile MachLitLit to ILX in IlxGen.lhs" (text "// MachLitLit!!! Not valid in ILX!!")
1007 pushLit env (MachAddr w) = text "ldc.i4 conv.i " <+> integer w
1011 | isGlobalName n = (nameReference env n) <> pprId (nameModule n) <> text "::" <> squotes (ppr (nameModule n) <> text "_" <> ppr (nameOccName n))
1012 | otherwise = pprId (nameOccName n)
1019 %************************************************************************
1021 \subsection{Printing types}
1023 %************************************************************************
1028 isVoidIlxRepType (NoteTy _ ty) = isVoidIlxRepType ty
1029 isVoidIlxRepType (TyConApp tc _) | (tyConPrimRep tc == VoidRep) = True
1030 isVoidIlxRepType (TyConApp tc tys)
1031 = case newTyConRep tc of
1032 Just rep_ty -> isVoidIlxRepType (applyTys rep_ty tys)
1034 isUnboxedTupleTyCon tc &&
1035 null (filter (not. isVoidIlxRepType) tys)
1036 isVoidIlxRepType _ = False
1038 isVoidIlxRepId id = isVoidIlxRepType (idType id)
1042 -- Get rid of all NoteTy and NewTy artifacts
1043 deepIlxRepType :: Type -> Type
1045 -- Eliminate state variables on left of arrow types...
1046 -- We have to be careful not to erase too much information here -
1047 -- the type may not accurately describe
1048 -- the "functionness" of the result. For example,
1052 -- which looks like an unboxed type. It isn't - it's
1053 -- just a function taking no arguments. As such, we
1054 -- have to rely on the context in which a function type is being
1055 -- used to know what to do.
1057 -- deepIlxRepType (FunTy l r) | isVoidIlxRepType l
1058 -- = deepIlxRepType r
1060 deepIlxRepType (FunTy l r)
1061 = FunTy (deepIlxRepType l) (deepIlxRepType r)
1063 deepIlxRepType (TyConApp tc tys)
1064 = case newTyConRep tc of
1065 Just rep_ty -> ASSERT( length tys == tyConArity tc )
1066 -- The assert should hold because deepIlxRepType should
1067 -- only be applied to *types* (of kind *)
1068 deepIlxRepType (applyTys rep_ty tys)
1070 -- collapse UnboxedTupleTyCon down when it contains VoidRep types.
1071 if isUnboxedTupleTyCon tc then
1072 let tys' = map deepIlxRepType (filter (not. isVoidIlxRepType) tys) in
1075 _ -> mkUnboxedTupleTy (length tys') tys'
1077 TyConApp tc (map deepIlxRepType tys)
1078 deepIlxRepType (AppTy f x) = AppTy (deepIlxRepType f) (deepIlxRepType x)
1079 deepIlxRepType (ForAllTy b ty) = ForAllTy b (deepIlxRepType ty)
1080 deepIlxRepType (NoteTy _ ty) = deepIlxRepType ty
1081 deepIlxRepType ty@(TyVarTy tv) = ty
1083 idIlxRepType id = deepIlxRepType (idType id)
1085 --------------------------
1086 -- Function types and type functions are implicitly thunkable.
1087 -- Some primitive type constructors are not thunkable.
1088 -- Everything else needs to be marked thunkable.
1089 pprIlxTypeL :: IlxEnv -> Type -> SDoc
1091 pprIlxTypeL env ty | isVoidIlxRepType ty
1092 = trace "pprIlxTypeL: VoidRep" pprIlxTypeR env ty
1094 pprIlxTypeL env ty@(FunTy arg res)
1095 = pprIlxTypeR env ty
1097 pprIlxTypeL env ty@(ForAllTy arg res)
1098 = pprIlxTypeR env ty
1100 pprIlxTypeL env ty@(TyConApp tc (h:t)) | isAlgTyCon tc && null (tyConTyVars tc)
1101 = ilxComment (text "what the fuck?") <+> (pprIlxTypeR env ty)
1102 pprIlxTypeL env ty@(TyConApp tc (h:t)) | isAlgTyCon tc && not (isIlxTyVar (hd (tyConTyVars tc)))
1103 = pprIlxTypeR env ty
1105 pprIlxTypeL env ty | isUnLiftedType ty -- must come after cases above because isUnLiftedType strips Forall's
1106 = pprIlxTypeR env ty
1109 = text "thunk" <> angleBrackets (pprIlxTypeR env ty)
1111 --------------------------
1112 -- Print non-thunkable version of type.
1115 pprIlxTypeR :: IlxEnv -> Type -> SDoc
1116 pprIlxTypeR env ty | isVoidIlxRepType ty = text "void"
1117 pprIlxTypeR env ty = pprIlxTypeR2 env ty
1119 pprIlxTypeR2 env ty@(AppTy f _) | isTyVarTy f = ilxComment (text "type app:" <+> pprId ty) <+> (text "class [mscorlib]System.Object")
1120 pprIlxTypeR2 env ty@(AppTy f x) = trace "pprIlxTypeR: should I be beta reducing types?!" (ilxComment (text "pprIlxTypeR: should I be beta reducing types...") <+> pprIlxTypeR env (applyTy f x))
1121 pprIlxTypeR2 env (TyVarTy tv) = pprIlxTyVar env tv
1123 -- The following is a special rule for types constructed out of
1124 -- higher kinds, e.g. Monad f or Functor f.
1126 -- The code below is not as general as it should be, but as I
1127 -- have no idea if this approach will even work, I'm going to
1128 -- just try it out on some simple cases arising from the prelude.
1129 pprIlxTypeR2 env ty@(TyConApp tc (h:t)) | isAlgTyCon tc && null (tyConTyVars tc)
1130 = ilxComment (text "what the fuck? 2") <+> (pprIlxTypeR env (TyConApp tc t))
1131 pprIlxTypeR2 env ty@(TyConApp tc (h:t)) | isAlgTyCon tc && not (isIlxTyVar (hd (tyConTyVars tc)))
1132 = pprIlxTypeR env (TyConApp tc t)
1133 pprIlxTypeR2 env (TyConApp tc args) = pprIlxTyConApp env tc args
1135 -- nb. the only legitimate place for VoidIlxRepTypes to occur in normalized IlxRepTypes
1136 -- is on the left of an arrow
1137 -- We could probably eliminate all but a final occurrence of these.
1138 --pprIlxTypeR2 env (FunTy arg res@(FunTy _ _)) | isVoidIlxRepType arg
1139 -- = pprIlxTypeR env res
1140 pprIlxTypeR2 env (FunTy arg res) | isVoidIlxRepType arg
1141 = parens (text "func () -->" <+> pprIlxTypeR env res)
1142 pprIlxTypeR2 env (FunTy arg res)
1143 = pprIlxFunTy (pprIlxTypeL env arg) (pprIlxTypeR env res)
1145 pprIlxTypeR2 env ty@(ForAllTy tv body_ty) | isIlxTyVar tv
1146 = parens (text "forall" <+> pprTyVarBinders env' [tv] <+> nest 2 (pprIlxTypeR env' body_ty))
1148 env' = extendIlxEnvWithFormalTyVars env [tv]
1150 pprIlxTypeR2 env ty@(ForAllTy tv body_ty) | otherwise
1151 = ilxComment (text "higher order type var " <+> pprId tv) <+>
1152 pprIlxFunTy (text "class [mscorlib]System.Object") (pprIlxTypeR env body_ty)
1154 pprIlxTypeR2 env (NoteTy _ ty)
1155 = trace "WARNING! non-representation type given to pprIlxTypeR: see generated ILX for context where this occurs"
1156 (vcat [text "/* WARNING! non-representation type given to pprIlxTypeR! */",
1157 pprIlxTypeR env ty ])
1160 pprIlxFunTy dom ran = parens (hsep [text "func",parens dom,text "-->", ran])
1162 pprIlxTyConApp env tc args =
1163 case lookupUFM tyPrimConTable (getUnique tc) of
1164 Just f -> f env args
1166 (if isUnboxedTupleTyCon tc then pprIlxUnBoxedTyConApp else pprIlxBoxedTyConApp)
1167 env ((nameReference env (getName tc)) <> (ppr tc)) args
1169 pprIlxUnBoxedTyConApp env tcdoc args = text "value class" <+> tcdoc <> pprTypeArgs pprIlxTypeL env args
1170 pprIlxBoxedTyConApp env tcdoc args = text "class" <+> tcdoc <> pprTypeArgs pprIlxTypeR env args
1172 -- Returns e.g: <Int32, Bool>
1173 pprTypeArgs f env tys = pprTypeArgs_aux f env (filter (not . isVoidIlxRepType) tys)
1175 pprTypeArgs_aux f env [] = empty
1176 pprTypeArgs_aux f env tys = angleBrackets (pprSepWithCommas (f env) tys)
1179 pprTyVarBinders :: IlxEnv -> [TyVar] -> SDoc
1180 -- Returns e.g: <class [mscorlib]System.Object> <class [mscorlib]System.Object>
1181 -- plus a new environment with the type variables added.
1182 pprTyVarBinders env [] = empty
1183 pprTyVarBinders env tvs = angleBrackets (pprSepWithCommas (pprTyVarBinder_aux env) tvs)
1185 pprTyVarBinder :: IlxEnv -> TyVar -> SDoc
1186 pprTyVarBinder env tv =
1187 if isIlxTyVar tv then
1188 angleBrackets (pprTyVarBinder_aux env tv)
1190 ilxComment (text "higher order tyvar" <+> pprId tv <+>
1191 text ":" <+> pprIlxTypeR env (tyVarKind tv)) <+>
1192 ilxComment (text "omitted")
1193 -- parens (text "class [mscorlib]System.Object" <+> pprId tv)
1196 pprTyVarBinder_aux env tv =
1197 ilxComment (text "tyvar" <+> pprId tv <+> text ":" <+>
1198 pprIlxTypeR env (tyVarKind tv)) <+>
1199 (text "class [mscorlib]System.Object")
1201 -- Only a subset of Haskell types can be generalized using the type quantification
1204 ( h == boxedTypeKind) ||
1205 ( h == unboxedTypeKind) ||
1206 ( h == openTypeKind) ||
1209 isIlxTyVar v = isTyVar v && isIlxForAllKind (tyVarKind v)
1211 categorizeVars fvs = (ilx_tvs, non_ilx_tvs, vs)
1213 (tvs, vs) = partition isTyVar fvs
1214 (ilx_tvs, non_ilx_tvs) = categorizeTyVars tvs
1216 categorizeTyVars tyvs = partition isIlxTyVar tyvs
1218 pprValArgTys ppr_ty env tys = parens (pprSepWithCommas (ppr_ty env) tys)
1220 pprId id = squotes (ppr id)
1221 squotes s = text "'" <> s <> text "'"
1225 %************************************************************************
1229 %************************************************************************
1232 type IlxTyEnv = [TyVar]
1235 -- Nb. There is currently no distinction between the kinds of type variables.
1236 -- We may need to add this to print out correct numbers, esp. for
1238 extendIlxTyEnvWithFreeTyVars env tyvars = env ++ mkIlxTyEnv tyvars -- bound by .closure x<...> in a closure declared with type parameters
1239 extendIlxTyEnvWithFormalTyVars env tyvars = env ++ mkIlxTyEnv tyvars -- bound by "forall <...>" in a type
1240 extendIlxTyEnvWithTyArgs env tyvars = env ++ mkIlxTyEnv tyvars -- bound by "<...>" in a closure implementing a universal type
1242 formalIlxTyEnv tyvars = mkIlxTyEnv tyvars
1243 mkIlxTyEnv tyvars = [ v | v <- tyvars, isIlxTyVar v ]
1245 pprIlxTyVarInIlxTyEnv :: IlxTyEnv -> TyVar -> SDoc
1246 pprIlxTyVarInIlxTyEnv tv_env tv
1250 = pprTrace "pprIlxTyVar" (pprId tv <+> text "tv_env = { "
1251 <+> pprSepWithCommas (\x -> pprId x <+> text ":"
1252 <+> pprIlxTypeR (IlxEnv (thisModule, tv_env, emptyVarEnv, emptyVarEnv, (empty,empty),False)) (tyVarKind x)) tv_env <+> text "}")
1253 (char '!' <> pprId tv)
1255 = {- pprTrace "go" (ppr (tyVarName tv) <+> ppr (tyVarName x)) -}
1256 (if tyVarName x== tyVarName tv then char '!' <> int n <+> ilxComment (char '!' <> pprId tv)
1260 data HowBound = Top Module -- Bound in a modules
1261 | Arg -- Arguments to the enclosing closure
1262 | CloVar Int -- A free variable of the enclosing closure
1263 -- The int is the index of the field in the
1265 | Local -- Local let binding
1267 -- The SDoc prints a unique name for the syntactic block we're currently processing,
1268 -- e.g. Foo_bar_baz when inside closure baz inside closure bar inside module Foo.
1269 data IlxEnv = IlxEnv (Module, IlxTyEnv, IdEnv HowBound,IdEnv (IlxEnv, StgRhs), Place,Bool)
1270 type Place = (SDoc,SDoc)
1271 thisModule = mkThisModule (mkSrcModule "")
1273 pprIlxTyVar (IlxEnv (_, tv_env, _, _,_,_)) tv = pprIlxTyVarInIlxTyEnv tv_env tv
1275 emptyIlxEnv :: Bool -> Module -> IlxEnv
1276 emptyIlxEnv trace mod = IlxEnv (mod, emptyIlxTyEnv, emptyVarEnv, emptyVarEnv, (ppr mod,empty),trace)
1278 nextPlace place sdoc = place <> sdoc
1279 usePlace place sdoc = place <> sdoc
1281 ilxEnvSetPlace (IlxEnv (m, tv_env, id_env, bind_env, (mod,exact),tr)) sdoc
1282 = IlxEnv (m, tv_env, id_env, bind_env, (mod, sdoc),tr)
1283 ilxEnvNextPlace (IlxEnv (m, tv_env, id_env, bind_env, (mod,exact),tr)) sdoc
1284 = IlxEnv (m, tv_env, id_env, bind_env, (mod, nextPlace exact sdoc),tr)
1285 ilxEnvQualifyByModule (IlxEnv (_, _, _, _,(mod,_),_)) sdoc = usePlace mod sdoc
1286 ilxEnvQualifyByExact (IlxEnv (_, _, _, _,(mod,exact),_)) sdoc = usePlace mod sdoc <> usePlace exact sdoc
1288 ilxPlaceStgBindDefault env = ilxEnvNextPlace env (text "D")
1289 ilxPlaceStgRhsClosure env bndr = ilxEnvSetPlace env (ppr bndr) -- binders are already unique
1290 ilxPlaceStgCaseScrut env = ilxEnvNextPlace env (text "S")
1292 ilxPlaceAlt :: IlxEnv -> Int -> IlxEnv
1293 ilxPlaceAlt env i = ilxEnvNextPlace env (text "a" <> int i)
1294 ilxPlacePrimAltLit env i = ilxEnvNextPlace env (text "P" <> int i)
1295 ilxMapPlaceArgs start f env args = [ f (ilxEnvNextPlace env (text "A" <> int i)) a | (i,a) <- [start..] `zip` args ]
1296 ilxMapPlaceAlts f env alts = [ f (ilxPlaceAlt env i) alt | (i,alt) <- [1..] `zip` alts ]
1298 extendIlxEnvWithFreeTyVars (IlxEnv (mod, tv_env, id_env, bind_env, place,tr)) tyvars
1299 = IlxEnv (mod, extendIlxTyEnvWithFreeTyVars tv_env tyvars,id_env, bind_env, place,tr)
1301 extendIlxEnvWithFormalTyVars (IlxEnv (mod, tv_env, id_env, bind_env, place,tr)) tyvars
1302 = IlxEnv (mod, extendIlxTyEnvWithFormalTyVars tv_env tyvars,id_env, bind_env, place,tr)
1304 extendIlxEnvWithTyArgs (IlxEnv (mod, tv_env, id_env, bind_env, place,tr)) tyvars
1305 = IlxEnv (mod, extendIlxTyEnvWithTyArgs tv_env tyvars,id_env, bind_env, place,tr)
1307 extendIlxEnvWithArgs :: IlxEnv -> [Var] -> IlxEnv
1308 extendIlxEnvWithArgs (IlxEnv (mod, tv_env, id_env, bind_env, place,tr)) args
1309 = IlxEnv (mod, extendIlxTyEnvWithTyArgs tv_env [tv | tv <- args, isIlxTyVar tv],
1310 extendVarEnvList id_env [(v,Arg) | v <- args, not (isIlxTyVar v)],
1313 extendIlxEnvWithFreeVars (IlxEnv (mod, tv_env, id_env, bind_env, place,tr)) args
1315 extendIlxTyEnvWithFreeTyVars tv_env [tv | tv <- args, isIlxTyVar tv],
1316 extendVarEnvList id_env (clovs 0 args),
1321 clovs n (x:xs) = if not (isIlxTyVar x) then (x,CloVar n):clovs (n+1) xs else clovs n xs
1323 extendIlxEnvWithBinds env@(IlxEnv (mod, tv_env, id_env, bind_env, place,tr)) bnds
1324 = IlxEnv (mod, tv_env, id_env,
1325 extendVarEnvList bind_env [(v,(env,rhs)) | (v,rhs) <- bnds],
1328 extendIlxEnvWithLocals (IlxEnv (m, tv_env, id_env, bind_env, p,tr)) locals
1329 = IlxEnv (m, tv_env,
1330 extendVarEnvList id_env [(v,Local) | (LocalId v,_) <- locals],
1331 extendVarEnvList bind_env [(v,(env,rhs)) | (LocalId v,Just (env,rhs)) <- locals],
1333 extendIlxEnvWithTops env@(IlxEnv (m, tv_env, id_env, bind_env, place,tr)) mod binds
1334 = IlxEnv (m, tv_env,
1335 extendVarEnvList id_env [(bndr,Top mod) | (bndr,rhs) <- binds],
1336 extendVarEnvList bind_env [(bndr,(env, rhs)) | (bndr,rhs) <- binds],
1339 formalIlxEnv (IlxEnv (m, tv_env, id_env, bind_env, place, tr)) tyvars
1340 = IlxEnv (m, formalIlxTyEnv tyvars, id_env, bind_env, place, tr)
1342 elemIlxTyVarEnv var env@(IlxEnv (_, tv_env, _,_,_,_)) = elem var tv_env
1343 elemIlxVarEnv var env@(IlxEnv (_, _, id_env,_,_,_)) = elemVarEnv var id_env
1344 lookupIlxVarEnv env@(IlxEnv (_, _, id_env,_,_,_)) var = lookupVarEnv id_env var
1345 lookupIlxBindEnv env@(IlxEnv (_, _, _, bind_env,_,_)) var = lookupVarEnv bind_env var
1351 type IlxLabel = SDoc
1353 pprIlxLabel lbl = lbl
1355 mkJoinLabel :: Id -> IlxLabel
1356 mkJoinLabel v = text "J_" <> ppr v
1358 mkAltLabel :: Id -> Int -> IlxLabel
1359 mkAltLabel v n = text "A" <> int n <> ppr v
1361 ilxLabel :: IlxLabel -> SDoc
1362 ilxLabel lbl = line $$ (pprIlxLabel lbl <> colon)
1366 %************************************************************************
1368 \subsection{Local pretty helper functions}
1370 %************************************************************************
1373 pprSepWithCommas :: (a -> SDoc) -> [a] -> SDoc
1374 pprSepWithCommas pp xs = sep (punctuate comma (map pp xs))
1375 ilxComment pp = text "/*" <+> pp <+> text "*/"
1376 singleQuotes pp = char '\'' <> pp <> char '\''
1377 squareBrackets pp = char '[' <> pp <> char ']'
1379 line = text "// ----------------------------------"
1381 nameReference (IlxEnv (thisMod, _, _, _, _, _)) n
1382 | isLocalName n = text "/* local */"
1383 | thisMod == nameModule n = text ""
1384 | isDllName n = squareBrackets ((text "ilx") <+> singleQuotes (text (_UNPK_ (modulePackageName (nameModule n))) <> hscOptionQual))
1385 | otherwise = squareBrackets ((text ".module") <+> (text "ilx") <+> singleQuotes (pprModuleName (moduleName (nameModule n)) <> hscOptionQual))
1387 hscOptionQual = if opt_DoEtaReduction then text ".O" else text ".Onot"
1388 moduleReference (IlxEnv (thisMod, _, _, _, _, _)) m
1389 | thisMod == m = text ""
1390 | isLocalModule m = squareBrackets ((text ".module") <+> (text "ilx") <+>singleQuotes (pprModuleName (moduleName m) <> hscOptionQual))
1391 | otherwise = squareBrackets ((text "ilx") <+> singleQuotes (text (_UNPK_ (modulePackageName m)) <> hscOptionQual))
1394 if preludePackage == opt_InPackage then squareBrackets (text ".module ilx PrelGHC" <> hscOptionQual)
1395 else squareBrackets (text "ilx" <+> text (_UNPK_ preludePackage) <> hscOptionQual)
1398 if preludePackage == opt_InPackage then squareBrackets (text ".module ilx PrelBase" <> hscOptionQual)
1399 else squareBrackets (text "ilx" <+> text (_UNPK_ preludePackage) <> hscOptionQual)
1401 ------------------------------------------------
1402 -- This code is copied from absCSyn/CString.lhs,
1403 -- and modified to do the correct thing! It's
1404 -- still a mess though. Also, still have to do the
1405 -- right thing for embedded nulls.
1407 pprFSInILStyle :: FAST_STRING -> SDoc
1408 pprFSInILStyle fs = doubleQuotes (text (stringToC (_UNPK_ fs)))
1410 stringToC :: String -> String
1411 -- Convert a string to the form required by C in a C literal string
1412 -- Tthe hassle is what to do w/ strings like "ESC 0"...
1414 stringToC [c] = charToC c
1416 -- if we have something "octifiable" in "c", we'd better "octify"
1417 -- the rest of the string, too.
1418 = if (c < ' ' || c > '~')
1419 then (charToC c) ++ (concat (map char_to_C cs))
1420 else (charToC c) ++ (stringToC cs)
1422 char_to_C c | c == '\n' = "\\n" -- use C escapes when we can
1424 | c == '\b' = "\\b" -- ToDo: chk some of these...
1429 | otherwise = '\\' : (trigraph (ord c))
1431 charToC :: Char -> String
1432 -- Convert a character to the form reqd in a C character literal
1433 charToC c = if (c >= ' ' && c <= '~') -- non-portable...
1446 else '\\' : (trigraph (ord c))
1448 trigraph :: Int -> String
1450 = [chr ((n `div` 100) `rem` 10 + ord '0'),
1451 chr ((n `div` 10) `rem` 10 + ord '0'),
1452 chr (n `rem` 10 + ord '0')]
1457 %************************************************************************
1459 \subsection{PrimOps and Constructors}
1461 %************************************************************************
1464 ----------------------------
1465 -- Allocate a fresh constructor
1467 ilxConApp env data_con args
1468 | isUnboxedTupleCon data_con
1469 = let tm_args' = filter (not. isVoidIlxRepType . stgArgType) tm_args in
1472 -- Collapse the construction of an unboxed tuple type where
1473 -- every element is zero-sized
1474 vcat (ilxMapPlaceArgs 0 pushArg env tm_args')
1476 -- Minimize the construction of an unboxed tuple type, which
1477 -- may contain zero-sized elements. Recompute all the
1478 -- bits and pieces from the simpler case below for the new data
1479 -- type constructor....
1480 let data_con' = unboxedTupleCon (length tm_args') in
1481 let rep_ty_args' = filter (not . isVoidIlxRepType) rep_ty_args in
1483 let tycon' = dataConTyCon data_con' in
1484 let (formal_tyvars', formal_tau_ty') = splitForAllTys (dataConRepType data_con') in
1485 let (formal_arg_tys', _) = splitFunTys formal_tau_ty' in
1486 let formal_env' = formalIlxEnv env formal_tyvars' in
1488 vcat [vcat (ilxMapPlaceArgs 0 pushArg env tm_args'),
1489 sep [text "newobj void ",
1490 pprIlxTyConApp env tycon' rep_ty_args',
1492 pprValArgTys pprIlxTypeR formal_env' (map deepIlxRepType formal_arg_tys')
1496 -- Now all other constructions
1497 = -- Assume C :: forall a. a -> T a -> T a
1498 -- ldloc x arg of type Int
1499 -- ldloc y arg of type T Int
1500 -- newdata classunion T<Int32>, C(!0, T <!0>)
1502 let tycon = dataConTyCon data_con in
1503 let (formal_tyvars, formal_tau_ty) = splitForAllTys (dataConRepType data_con) in
1504 let (formal_arg_tys, _) = splitFunTys formal_tau_ty in
1506 vcat [vcat (ilxMapPlaceArgs 0 pushArg env tm_args),
1507 sep [ text "newdata",
1508 nest 2 (pprIlxTyConApp env tycon rep_ty_args <> comma),
1509 nest 2 (ilxConRef env data_con)
1513 tycon = dataConTyCon data_con
1514 rep_ty_args = map deepIlxRepType ty_args
1515 (ty_args,tm_args) = if isAlgTyCon tycon then splitTyArgs (tyConTyVars tycon) args else splitTyArgs1 args
1517 -- split some type arguments off, throwing away the higher kinded ones for the moment
1518 -- base the higher-kinded checks off a corresponding list of formals
1519 splitTyArgs (htv:ttv) (StgTypeArg h:t)
1520 | isIlxTyVar htv = ((h:l), r)
1521 | otherwise = trace "splitTyArgs: threw away higher kinded type arg" (l, r)
1522 where (l,r) = splitTyArgs ttv t
1523 splitTyArgs _ l = ([],l)
1525 -- split some type arguments off, where none should be higher kinded
1526 splitTyArgs1 (StgTypeArg h:t)
1528 where (l,r) = splitTyArgs1 t
1529 splitTyArgs1 l = ([],l)
1532 ilxConRef env data_con
1533 = pprId data_con <> pprValArgTys pprIlxTypeL env' (map deepIlxRepType (filter (not . isVoidIlxRepType) arg_tys))
1535 (tyvars, tau_ty) = splitForAllTys (dataConRepType data_con)
1536 (arg_tys, _) = splitFunTys tau_ty
1537 env' = formalIlxEnv env tyvars
1540 tyPrimConTable :: UniqFM (IlxEnv -> [Type] -> SDoc)
1541 tyPrimConTable = listToUFM [(addrPrimTyConKey, (\_ _ -> repAddr)),
1542 (fileStreamPrimTyConKey, (\_ _ -> repFileStream)),
1543 (foreignObjPrimTyConKey, (\_ _ -> text "/* ForeignObj */ void *")),
1544 -- (stablePtrPrimTyConKey, (\_ _ -> text "/* StablePtr */ void *")),
1545 (charPrimTyConKey, (\_ _ -> repChar)),
1546 (wordPrimTyConKey, (\_ _ -> repWord)),
1547 (byteArrayPrimTyConKey, (\_ _ -> repByteArray)),
1548 (intPrimTyConKey, (\_ _ -> repInt)),
1549 (int64PrimTyConKey, (\_ _ -> repInt64)),
1550 (word64PrimTyConKey, (\_ _ -> repWord64)),
1551 (floatPrimTyConKey, (\_ _ -> text "float32")),
1552 (arrayPrimTyConKey, (\env [ty] -> pprIlxTypeL env ty <> text "[]")),
1553 (mutableArrayPrimTyConKey, (\env [_, ty] -> pprIlxTypeL env ty <> text "[]")),
1554 (mVarPrimTyConKey, (\env [_, ty] -> repMVar (pprIlxTypeL env ty))),
1555 (mutVarPrimTyConKey, (\env [ty1, ty2] -> repMutVar (pprIlxTypeL env ty1) (pprIlxTypeL env ty2))),
1556 (mutableByteArrayPrimTyConKey, (\_ _ -> repByteArray)),
1557 (threadIdPrimTyConKey, (\_ _ -> text "class [mscorlib]System.Threading.Thread /* ThreadId# */ ")),
1558 (doublePrimTyConKey, (\_ _ -> text "float64"))
1564 %************************************************************************
1566 \subsection{C Calls}
1568 %************************************************************************
1572 -- We eliminate voids in and around an IL C Call. We don't yet emit PInvoke stubs.
1573 -- We also do some type-directed translation for pinning Haskell-managed blobs
1574 -- of data as we throw them across the boundary.
1575 ilxCCall env (CCall (StaticTarget c) casm gc cconv) args ret_ty =
1576 ilxComment (text "C call <+> pprCLabelString c") <+>
1577 vcat [vcat (ilxMapPlaceArgs 0 pushCArg env args),
1578 text "call" <+> retdoc <+> text "class " <+> prelGHCReference <+> text "PrelGHC::" <+> pprCLabelString c <+> pprTypeArgs pprIlxTypeR env ty_args
1579 <+> pprCValArgTys pprIlxTypeL env (map deepIlxRepType (filter (not. isVoidIlxRepType) (map stgArgType tm_args))) ]
1582 if isVoidIlxRepType ret_ty then text "void"
1583 else pprIlxTypeR env (deepIlxRepType ret_ty)
1584 (ty_args,tm_args) = splitTyArgs1 args
1587 hasTyCon (TyConApp tc _) tc2 = tc == tc2
1588 hasTyCon _ _ = False
1590 isByteArrayCArgTy ty = hasTyCon ty byteArrayPrimTyCon || hasTyCon ty mutableByteArrayPrimTyCon
1591 isByteArrayCArg v = isByteArrayCArgTy (deepIlxRepType (idType v))
1592 pinCCallArg v = isByteArrayCArg v
1594 ilxAddrOfPinnedByteArr = text "ldc.i4 0 ldelema unsigned int8"
1596 pushCArg env arg@(StgVarArg v) | isByteArrayCArg v = pushArg env arg <+> text "dup stloc" <+> squotes (ilxEnvQualifyByExact env (ppr v) <> text "pin") <+> ilxAddrOfPinnedByteArr
1597 pushCArg env arg | otherwise = pushArg env arg
1599 pprCValArgTys f env tys = parens (pprSepWithCommas (pprCValArgTy f env) tys)
1600 pprCValArgTy f env ty | isByteArrayCArgTy ty = text "void *" <+> ilxComment (text "interior pointer into ByteArr#")
1601 pprCValArgTy f env ty | otherwise = f env ty
1606 %************************************************************************
1608 \subsection{PrimOps}
1610 %************************************************************************
1614 ilxPrimApp env (CCallOp ccall) args ret_ty = ilxCCall env ccall args ret_ty
1616 ilxPrimApp env op args ret_ty
1617 = case lookupFM ilxPrimOpTable op of
1618 Just fn -> fn env args
1619 Nothing -> ilxComment (simp_op (text "Unknown primop!:" <+> pprId op) env args)
1623 ilxMkBool = text "call class" <+> prelBaseReference <+>
1624 text "PrelBase_Bool" <+>
1625 prelGHCReference <+> text "GHC.support::mkBool(bool)"
1626 ilxCgt = text "cgt " <+> ilxMkBool
1627 ilxCge = text "clt ldc.i4 0 ceq " <+> ilxMkBool
1628 ilxClt = text "clt " <+> ilxMkBool
1629 ilxCle = text "cgt ldc.i4 0 ceq " <+> ilxMkBool
1630 ilxCeq = text "ceq " <+> ilxMkBool
1631 ilxCne = text "ceq ldc.i4 0 ceq " <+> ilxMkBool
1632 ilxCgtUn = text "cgt.un " <+> ilxMkBool
1633 ilxCgeUn = text "clt.un ldc.i4 0 ceq " <+> ilxMkBool
1634 ilxCltUn = text "clt.un " <+> ilxMkBool
1635 ilxCleUn = text "cgt.un ldc.i4 0 ceq " <+> ilxMkBool
1636 ldDummyInteger = text " ldc.i4 0 ldnull newobj void" <+> ilxUnboxedPairRep repInt repByteArray <+> text "::.ctor(!0,!1)"
1637 ldDummyInteger2 = text " ldc.i4 0 ldnull ldc.i4 0 ldnull newobj void" <+> ilxUnboxedQuadRep repInt repByteArray repInt repByteArray <+> text "::.ctor(!0,!1,!2,!3)"
1639 repByteArray = text "unsigned int8[] /* ByteArr# */ "
1640 repFileStream = text "void * /* FileStream# */ " -- text "class [mscorlib]System.IO.FileStream"
1641 repInt = text "int32"
1642 repWord = text "unsigned int32"
1643 repAddr = text "/* Addr */ void *"
1644 repInt64 = text "int64"
1645 repWord64 = text "unsigned int64"
1646 repChar = text "/* Char */ unsigned int8"
1647 repInteger = ilxUnboxedPairRep repInt repByteArray
1648 repIntegerPair = ilxUnboxedQuadRep repInt repByteArray repInt repByteArray
1649 repMVar ty = text "class " <+> prelGHCReference <+> text "PrelGHC_MVarzh" <+> ilxTyParams [ty]
1650 repMutVar _ ty2 = text "class " <+> prelGHCReference <+> text "PrelGHC_MutVarzh" <+> ilxTyParams [ty2]
1651 repWeak ty1 = text "class " <+> prelGHCReference <+> text "PrelGHC_Weakzh" <+> ilxTyParams [ty1]
1653 ilxParamsAux [] = empty
1654 ilxParamsAux [h] = h
1655 ilxParamsAux (h:t) = h <> text "," <+> ilxParamsAux t
1656 ilxParams [] = empty
1657 ilxParams l = parens (ilxParamsAux l)
1659 ilxTyParamsAux [] = empty
1660 ilxTyParamsAux [h] = h
1661 ilxTyParamsAux (h:t) = h <> text "," <+> ilxTyParamsAux t
1662 ilxTyParams [] = empty
1663 ilxTyParams l = angleBrackets (ilxTyParamsAux l)
1665 ilxMethA = text "!!0"
1667 ilxTyPair l r = ilxTyParams [l,r]
1668 ilxTyTriple l m r = ilxTyParams [l,m,r]
1669 ilxTyQuad l m1 m2 r = ilxTyParams [l,m1,m2,r]
1670 ilxUnboxedPairRep l r = text "value class" <+> prelGHCReference <+> text "PrelGHC_ZLzhzx2czhZR" <+> ilxTyPair l r
1671 ilxUnboxedTripleRep l m r = text "value class" <+> prelGHCReference <+> text "PrelGHC_ZLzhzx2czx2czhZR" <+> ilxTyTriple l m r
1672 ilxUnboxedQuadRep l m1 m2 r = text "value class" <+> prelGHCReference <+> text "PrelGHC_ZLzhzx2czx2czx2czhZR" <+> ilxTyQuad l m1 m2 r
1674 ilxMethodRef rty cls nm tyargs args = rty <+> cls <+> text "::" <> squotes (text nm) <> ilxTyParams tyargs <> ilxParams args
1676 ilxSupportClass = prelGHCReference <+> text "GHC.support"
1677 ilxSuppMeth rty nm tyargs args = ilxMethodRef rty ilxSupportClass nm tyargs args
1679 ilxPrimOpTable :: FiniteMap PrimOp (IlxEnv -> [StgArg] -> SDoc)
1681 listToFM [(CharGtOp, simp_op ilxCgt),
1682 (CharGeOp, simp_op ilxCge),
1683 (CharEqOp, simp_op ilxCeq),
1684 (CharNeOp, simp_op ilxCne),
1685 (CharLtOp, simp_op ilxClt),
1686 (CharLeOp, simp_op ilxCle),
1688 (OrdOp, simp_op (text "conv.i4")), -- chars represented by UInt32 (u4)
1689 (ChrOp, simp_op (text "conv.u4")),
1691 (IntGtOp, simp_op ilxCgt),
1692 (IntGeOp, simp_op ilxCge),
1693 (IntEqOp, simp_op ilxCeq),
1694 (IntNeOp, simp_op ilxCne),
1695 (IntLtOp, simp_op ilxClt),
1696 (IntLeOp, simp_op ilxCle),
1698 (WordGtOp, simp_op ilxCgtUn), -- words represented by UInt32 (u4)
1699 (WordGeOp, simp_op ilxCgeUn),
1700 (WordEqOp, simp_op ilxCeq),
1701 (WordNeOp, simp_op ilxCne),
1702 (WordLtOp, simp_op ilxCltUn),
1703 (WordLeOp, simp_op ilxCleUn),
1705 (AddrGtOp, simp_op ilxCgt),
1706 (AddrGeOp, simp_op ilxCge),
1707 (AddrEqOp, simp_op ilxCeq),
1708 (AddrNeOp, simp_op ilxCne),
1709 (AddrLtOp, simp_op ilxClt),
1710 (AddrLeOp, simp_op ilxCle),
1712 (FloatGtOp, simp_op ilxCgt),
1713 (FloatGeOp, simp_op ilxCge),
1714 (FloatEqOp, simp_op ilxCeq),
1715 (FloatNeOp, simp_op ilxCne),
1716 (FloatLtOp, simp_op ilxClt),
1717 (FloatLeOp, simp_op ilxCle),
1719 (DoubleGtOp, simp_op ilxCgt),
1720 (DoubleGeOp, simp_op ilxCge),
1721 (DoubleEqOp, simp_op ilxCeq),
1722 (DoubleNeOp, simp_op ilxCne),
1723 (DoubleLtOp, simp_op ilxClt),
1724 (DoubleLeOp, simp_op ilxCle),
1726 -- Int#-related ops:
1727 (IntAddOp, simp_op (text "add")),
1728 (IntSubOp, simp_op (text "sub")),
1729 (IntMulOp, simp_op (text "mul")),
1730 (IntQuotOp, simp_op (text "div")),
1731 (IntNegOp, simp_op (text "neg")),
1732 (IntRemOp, simp_op (text "rem")),
1734 (Addr2IntOp, simp_op (text "conv.i4")), -- Addresses are very dodgy for ILX. They are used for both C-strings and
1735 (Int2AddrOp, simp_op (text "conv.i")), -- the FFI. This needs more work.
1736 (ISllOp, simp_op (text "shl")),
1737 (ISraOp, simp_op (text "shr")),
1738 (ISrlOp, simp_op (text "shr.un")),
1739 (IntAddCOp, simp_op (text "call" <+> ilxSuppMeth (ilxUnboxedPairRep repInt repInt) "IntAddCOp" [] [repInt, repInt])),
1740 (IntAddCOp, simp_op (text "call" <+> ilxSuppMeth (ilxUnboxedPairRep repInt repInt) "IntSubCOp" [] [repInt, repInt])),
1741 (IntAddCOp, simp_op (text "call" <+> ilxSuppMeth (ilxUnboxedPairRep repInt repInt) "IntMulCOp" [] [repInt, repInt])),
1742 (IntGcdOp, simp_op (text "call" <+> ilxSuppMeth repInt "IntMulCOp" [] [repInt, repInt])),
1745 -- Word#-related ops:
1746 (AndOp, simp_op (text "and")),
1747 (OrOp, simp_op (text "or")),
1748 (NotOp, simp_op (text "not")),
1749 (XorOp, simp_op (text "xor")),
1750 (SllOp, simp_op (text "shl")),
1751 (SrlOp, simp_op (text "shr")),
1752 (Word2IntOp, simp_op (text "conv.i4")),
1753 (Int2WordOp, simp_op (text "conv.u4")),
1755 -- Float#-related ops:
1756 (FloatAddOp, simp_op (text "add")),
1757 (FloatSubOp, simp_op (text "sub")),
1758 (FloatMulOp, simp_op (text "mul")),
1759 (FloatDivOp, simp_op (text "div")),
1760 (FloatNegOp, simp_op (text "neg")),
1761 (Float2IntOp, simp_op (text "conv.i4")),
1762 (Int2FloatOp, simp_op (text "conv.r4")),
1764 (DoubleAddOp, simp_op (text "add")),
1765 (DoubleSubOp, simp_op (text "sub")),
1766 (DoubleMulOp, simp_op (text "mul")),
1767 (DoubleDivOp, simp_op (text "div")),
1768 (DoubleNegOp, simp_op (text "neg")),
1769 (Double2IntOp, simp_op (text "conv.i4")),
1770 (Int2DoubleOp, simp_op (text "conv.r4")),
1771 (Double2FloatOp, simp_op (text "conv.r4")),
1772 (Float2DoubleOp, simp_op (text "conv.r8")),
1773 (DoubleDecodeOp, simp_op (text "call" <+> ilxSuppMeth (ilxUnboxedTripleRep repInt repInt repByteArray) "decodeDouble" [] [text "float64"])),
1774 (FloatDecodeOp, simp_op (text "call" <+> ilxSuppMeth (ilxUnboxedTripleRep repInt repInt repByteArray) "decodeFloat" [] [text "float32"])),
1776 (FloatExpOp, simp_op (text "conv.r8 call float64 [mscorlib]System.Math::Exp(float64) conv.r4")),
1777 (FloatLogOp, simp_op (text "conv.r8 call float64 [mscorlib]System.Math::Log(float64) conv.r4")),
1778 (FloatSqrtOp, simp_op (text "conv.r8 call float64 [mscorlib]System.Math::Sqrt(float64) conv.r4")),
1779 (FloatSinOp, simp_op (text "conv.r8 call float64 [mscorlib]System.Math::Sin(float64) conv.r4")),
1780 (FloatCosOp, simp_op (text "conv.r8 call float64 [mscorlib]System.Math::Cos(float64) conv.r4")),
1781 (FloatTanOp, simp_op (text "conv.r8 call float64 [mscorlib]System.Math::Tan(float64) conv.r4")),
1782 (FloatAsinOp, simp_op (text "conv.r8 call float64 [mscorlib]System.Math::Asin(float64) conv.r4")),
1783 (FloatAcosOp, simp_op (text "conv.r8 call float64 [mscorlib]System.Math::Acos(float64) conv.r4")),
1784 (FloatAtanOp, simp_op (text "conv.r8 call float64 [mscorlib]System.Math::Atan(float64) conv.r4")),
1785 (FloatSinhOp, simp_op (text "conv.r8 call float64 [mscorlib]System.Math::Sinh(float64) conv.r4")),
1786 (FloatCoshOp, simp_op (text "conv.r8 call float64 [mscorlib]System.Math::Cosh(float64) conv.r4")),
1787 (FloatTanhOp, simp_op (text "conv.r8 call float64 [mscorlib]System.Math::Tanh(float64) conv.r4")),
1788 (FloatPowerOp, simp_op (text "call float64 [mscorlib]System.Math::Pow(float64, float64) conv.r4")), -- ** op, make use of implicit cast to r8...
1790 (DoubleExpOp, simp_op (text "call float64 [mscorlib]System.Math::Exp(float64)")),
1791 (DoubleLogOp, simp_op (text "call float64 [mscorlib]System.Math::Log(float64)")),
1792 (DoubleSqrtOp, simp_op (text "call float64 [mscorlib]System.Math::Sqrt(float64)")),
1794 (DoubleSinOp, simp_op (text "call float64 [mscorlib]System.Math::Sin(float64)")),
1795 (DoubleCosOp, simp_op (text "call float64 [mscorlib]System.Math::Cos(float64)")),
1796 (DoubleTanOp, simp_op (text "call float64 [mscorlib]System.Math::Tan(float64)")),
1798 (DoubleAsinOp, simp_op (text "call float64 [mscorlib]System.Math::Asin(float64)")),
1799 (DoubleAcosOp, simp_op (text "call float64 [mscorlib]System.Math::Acos(float64)")),
1800 (DoubleAtanOp, simp_op (text "call float64 [mscorlib]System.Math::Atan(float64)")),
1802 (DoubleSinhOp, simp_op (text "call float64 [mscorlib]System.Math::Sinh(float64)")),
1803 (DoubleCoshOp, simp_op (text "call float64 [mscorlib]System.Math::Cosh(float64)")),
1804 (DoubleTanhOp, simp_op (text "call float64 [mscorlib]System.Math::Tanh(float64)")),
1806 (DoublePowerOp, simp_op (text "call float64 [mscorlib]System.Math::Pow(float64, float64)")),
1808 -- Integer (and related...) ops: bail out to support routines
1809 (IntegerAddOp, simp_op (text "call" <+> ilxSuppMeth repInteger "IntegerAddOp" [] [repInt, repByteArray, repInt, repByteArray])),
1810 (IntegerSubOp, simp_op (text "call" <+> ilxSuppMeth repInteger "IntegerSubOp" [] [repInt, repByteArray, repInt, repByteArray])),
1811 (IntegerMulOp, simp_op (text "call" <+> ilxSuppMeth repInteger "IntegerMulOp" [] [repInt, repByteArray, repInt, repByteArray])),
1812 (IntegerGcdOp, simp_op (text "call" <+> ilxSuppMeth repInteger "IntegerGcdOp" [] [repInt, repByteArray, repInt, repByteArray])),
1813 (IntegerQuotRemOp, simp_op (text "call" <+> ilxSuppMeth repIntegerPair "IntegerQuotRemOp" [] [repInt, repByteArray, repInt, repByteArray])),
1814 (IntegerDivModOp, simp_op (text "call" <+> ilxSuppMeth repIntegerPair "IntegerDivModOp" [] [repInt, repByteArray, repInt, repByteArray])),
1815 (IntegerNegOp, simp_op (text "call" <+> ilxSuppMeth repInteger "IntegerNegOp" [] [repInt, repByteArray])),
1816 (IntegerIntGcdOp, simp_op (text "call" <+> ilxSuppMeth repInt "IntegerIntGcdOp" [] [repInt, repByteArray, repInt])),
1817 (IntegerDivExactOp, simp_op (text "call" <+> ilxSuppMeth repInteger "IntegerDivExactOp" [] [repInt, repByteArray, repInt, repByteArray])),
1818 (IntegerQuotOp, simp_op (text "call" <+> ilxSuppMeth repInteger "IntegerQuotOp" [] [repInt, repByteArray, repInt, repByteArray])),
1819 (IntegerRemOp, simp_op (text "call" <+> ilxSuppMeth repInteger "IntegerRemOp" [] [repInt, repByteArray, repInt, repByteArray])),
1820 (IntegerCmpOp, simp_op (text "call" <+> ilxSuppMeth repInt "IntegerCmpOp" [] [repInt, repByteArray, repInt, repByteArray])),
1821 (IntegerCmpIntOp, simp_op (text "call" <+> ilxSuppMeth repInt "IntegerCmpIntOp" [] [repInt, repByteArray, repInt])),
1822 (Integer2IntOp, simp_op (text "call" <+> ilxSuppMeth repInt "Integer2IntOp" [] [repInt, repByteArray])),
1823 (Integer2WordOp, simp_op (text "call" <+> ilxSuppMeth repWord "Integer2WordOp" [] [repInt, repByteArray])),
1824 (Int2IntegerOp, simp_op (text "call" <+> ilxSuppMeth repInteger "Int2IntegerOp" [] [repInt])),
1825 (Word2IntegerOp, simp_op (text "call" <+> ilxSuppMeth repInteger "Word2IntegerOp" [] [repWord])),
1826 (Addr2IntegerOp, simp_op (text "call" <+> ilxSuppMeth repInteger "Addr2IntegerOp" [] [repAddr])),
1827 (IntegerToInt64Op, simp_op (text "call" <+> ilxSuppMeth repAddr "IntegerToInt64Op" [] [repInt,repByteArray])),
1828 (Int64ToIntegerOp, simp_op (text "call" <+> ilxSuppMeth repInteger "Int64ToIntegerOp" [] [repInt64])),
1829 (IntegerToWord64Op, simp_op (text "call" <+> ilxSuppMeth repWord64 "IntegerToWord64Op" [] [repInt,repByteArray])),
1830 (Word64ToIntegerOp, simp_op (text "call" <+> ilxSuppMeth repInteger "Word64ToIntegerOp" [] [repWord64])),
1832 (IndexOffForeignObjOp CharRep, simp_op (text "add ldind.u1")),
1833 (IndexOffForeignObjOp IntRep, simp_op (text "ldc.i4 4 mul add ldind.i4")),
1834 (IndexOffForeignObjOp WordRep, simp_op (text "ldc.i4 4 mul add ldind.u4")),
1835 (IndexOffForeignObjOp AddrRep, warn_op "IndexOffForeignObjOp AddrRep: assuing 32 bit architecture" (simp_op (text "ldc.i4 4 mul add ldind.i "))),
1836 (IndexOffForeignObjOp FloatRep, simp_op (text "ldc.i4 4 mul add ldind.r4")),
1837 (IndexOffForeignObjOp DoubleRep, simp_op (text "ldc.i4 8 mul add ldind.r8")),
1838 (IndexOffForeignObjOp Int64Rep, simp_op (text "ldc.i4 8 mul add ldind.i8")),
1839 (IndexOffForeignObjOp Word64Rep, simp_op (text "ldc.i4 8 mul add ldind.u8")),
1841 (IndexOffAddrOp CharRep, simp_op (text "add ldind.u1")),
1842 (IndexOffAddrOp IntRep, simp_op (text "ldc.i4 4 mul add ldind.i4")),
1843 (IndexOffAddrOp WordRep, simp_op (text "ldc.i4 4 mul add ldind.u4")),
1844 (IndexOffAddrOp AddrRep, warn_op "IndexOffAddrOp AddrRep: assuing 32 bit architecture" (simp_op (text "ldc.i4 4 mul add ldind.i"))),
1845 (IndexOffAddrOp FloatRep, simp_op (text "ldc.i4 4 mul add ldind.r4")),
1846 (IndexOffAddrOp DoubleRep, simp_op (text "ldc.i4 8 mul add ldind.r8")),
1847 (IndexOffAddrOp Int64Rep, simp_op (text "ldc.i4 8 mul add ldind.i8")),
1848 (IndexOffAddrOp Word64Rep, simp_op (text "ldc.i4 8 mul add ldind.u8")),
1851 (WriteOffAddrOp CharRep, ty1_arg4_op (\sty addr n v s -> addr <+> n <+> text "add" <+> v <+> text "stind.u1")),
1852 (WriteOffAddrOp IntRep, ty1_arg4_op (\sty addr n v s -> addr <+> n <+> text "ldc.i4 4 mul add" <+> v <+> text "stind.i4")),
1853 (WriteOffAddrOp WordRep, ty1_arg4_op (\sty addr n v s -> addr <+> n <+> text "ldc.i4 4 mul add" <+> v <+> text "stind.u4")),
1854 (WriteOffAddrOp AddrRep, ty1_arg4_op (\sty addr n v s -> addr <+> n <+> text "ldc.i4 4 mul add" <+> v <+> text "stind.i")),
1855 (WriteOffAddrOp FloatRep, ty1_arg4_op (\sty addr n v s -> addr <+> n <+> text "ldc.i4 4 mul add" <+> v <+> text "stind.r4")),
1856 (WriteOffAddrOp DoubleRep, ty1_arg4_op (\sty addr n v s -> addr <+> n <+> text "ldc.i4 8 mul add" <+> v <+> text "stind.r8")),
1857 (WriteOffAddrOp Int64Rep, ty1_arg4_op (\sty addr n v s -> addr <+> n <+> text "ldc.i4 8 mul add" <+> v <+> text "stind.i8")),
1858 (WriteOffAddrOp Word64Rep, ty1_arg4_op (\sty addr n v s -> addr <+> n <+> text "ldc.i4 8 mul add" <+> v <+> text "stind.u8")),
1859 {- Addr# -> Int# -> Char# -> State# s -> State# s -}
1861 (ReadOffAddrOp CharRep, simp_op (text "add ldind.u1")),
1862 (ReadOffAddrOp IntRep, simp_op (text "ldc.i4 4 mul add ldind.i4")),
1863 (ReadOffAddrOp WordRep, simp_op (text "ldc.i4 4 mul add ldind.u4")),
1864 (ReadOffAddrOp AddrRep, simp_op (text "ldc.i4 4 mul add ldind.i")),
1865 (ReadOffAddrOp FloatRep, simp_op (text "ldc.i4 4 mul add ldind.r4")),
1866 (ReadOffAddrOp DoubleRep, simp_op (text "ldc.i4 8 mul add ldind.r8")),
1867 (ReadOffAddrOp Int64Rep, simp_op (text "ldc.i4 8 mul add ldind.i8")),
1868 (ReadOffAddrOp Word64Rep, simp_op (text "ldc.i4 8 mul add ldind.u8")),
1869 {- Addr# -> Int# -> Char# -> State# s -> State# s -}
1871 (RaiseOp, ty2_op (\ty1 ty2 -> text "throw")),
1872 (CatchOp, ty2_op (\ty1 ty2 ->
1873 text "call" <+> ilxSuppMeth ilxMethA "catch" [ty1,ty2] [text "(func () --> !!0)", text "(func (!!1) --> (func () --> !!0))"])),
1874 {- (State# RealWorld -> (# State# RealWorld, a #) )
1875 -> (b -> State# RealWorld -> (# State# RealWorld, a #) )
1877 -> (# State# RealWorld, a #)
1880 (BlockAsyncExceptionsOp, ty1_op (\ty1 ->
1881 text "call" <+> ilxSuppMeth ilxMethA "blockAsyncExceptions" [ty1] [text "(func () --> !!0)"])),
1883 {- (State# RealWorld -> (# State# RealWorld, a #))
1884 -> (State# RealWorld -> (# State# RealWorld, a #))
1887 (UnblockAsyncExceptionsOp, ty1_op (\ty1 ->
1888 text "call" <+> ilxSuppMeth ilxMethA "unblockAsyncExceptions" [ty1] [text "(func () --> !!0)"])),
1891 (State# RealWorld -> (# State# RealWorld, a #))
1892 -> (State# RealWorld -> (# State# RealWorld, a #))
1895 (NewMVarOp, ty2_op (\sty ty ->
1896 text "newobj void " <+> repMVar ty <+> text "::.ctor()")),
1897 {- State# s -> (# State# s, MVar# s a #) -}
1899 (TakeMVarOp, ty2_op (\sty ty ->
1900 text "call" <+> ilxSuppMeth ilxMethA "takeMVar" [ty] [repMVar ilxMethA])),
1901 {- MVar# s a -> State# s -> (# State# s, a #) -}
1903 (PutMVarOp, ty2_op (\sty ty ->
1904 text "call" <+> ilxSuppMeth (text "void") "putMVar" [ty] [repMVar ilxMethA, ilxMethA])),
1905 {- MVar# s a -> a -> State# s -> State# s -}
1907 (SameMVarOp, ty2_op (\sty ty -> text "ceq " <+> ilxMkBool)),
1908 {- MVar# s a -> MVar# s a -> Bool -}
1910 (TakeMaybeMVarOp, ty2_op (\sty ty ->
1911 text "call" <+> ilxSuppMeth (ilxUnboxedPairRep repInt ilxMethA) "tryTakeMVar" [ty] [repMVar ilxMethA])),
1913 {- MVar# s a -> State# s -> (# State# s, Int#, a #) -}
1915 (IsEmptyMVarOp, ty2_op (\sty ty ->
1916 text "call" <+> ilxSuppMeth repInt "isEmptyMVar" [ty] [repMVar ilxMethA])),
1917 {- MVar# s a -> State# s -> (# State# s, Int# #) -}
1919 (DataToTagOp, ty1_op (\ty1 ->
1920 text "call" <+> ilxSuppMeth repInt "dataToTag" [ty1] [ilxMethA])),
1923 (TagToEnumOp, ty1_op (\ty1 ->
1924 text "call" <+> ilxSuppMeth ilxMethA "tagToEnum" [ty1] [repInt])),
1927 (IndexByteArrayOp CharRep, simp_op (text "ldelem.u1")),
1928 (IndexByteArrayOp IntRep, simp_op (text "ldelem.i4")),
1929 (IndexByteArrayOp WordRep, simp_op (text "ldelem.u4")),
1930 (IndexByteArrayOp AddrRep, simp_op (text "ldelem.u")),
1931 (IndexByteArrayOp FloatRep, simp_op (text "ldelem.r4")),
1932 (IndexByteArrayOp DoubleRep, simp_op (text "ldelem.r8")),
1933 (IndexByteArrayOp StablePtrRep, simp_op (text "ldelem.i4")),
1934 (IndexByteArrayOp Int64Rep, simp_op (text "ldelem.i8")),
1935 (IndexByteArrayOp Word64Rep, simp_op (text "ldelem.u8")),
1937 {- ByteArr# -> Int# -> Char# -}
1939 (WriteByteArrayOp CharRep, simp_op (text "stelem.u1")),
1940 (WriteByteArrayOp IntRep, simp_op (text "stelem.i4")),
1941 (WriteByteArrayOp WordRep, simp_op (text "stelem.u4")),
1942 (WriteByteArrayOp AddrRep, simp_op (text "stelem.u")),
1943 (WriteByteArrayOp FloatRep, simp_op (text "stelem.r4")),
1944 (WriteByteArrayOp DoubleRep, simp_op (text "stelem.r8")),
1945 (WriteByteArrayOp StablePtrRep, simp_op (text "stelem.i4")),
1946 (WriteByteArrayOp Int64Rep, simp_op (text "stelem.i8")),
1947 (WriteByteArrayOp Word64Rep, simp_op (text "stelem.u8")),
1949 {- MutByteArr# s -> Int# -> Char# -> State# s -> State# s -}
1951 {- should be monadic??? -}
1952 (ReadByteArrayOp CharRep, simp_op (text "ldelem.u1")),
1953 (ReadByteArrayOp IntRep, simp_op (text "ldelem.i4")),
1954 (ReadByteArrayOp WordRep, simp_op (text "ldelem.u4")),
1955 (ReadByteArrayOp AddrRep, simp_op (text "ldelem.u")),
1956 (ReadByteArrayOp FloatRep, simp_op (text "ldelem.r4")),
1957 (ReadByteArrayOp DoubleRep, simp_op (text "ldelem.r8")),
1958 (ReadByteArrayOp StablePtrRep, simp_op (text "ldelem.i4")),
1959 (ReadByteArrayOp Int64Rep, simp_op (text "ldelem.i8")),
1960 (ReadByteArrayOp Word64Rep, simp_op (text "ldelem.u8")),
1961 {- MutByteArr# s -> Int# -> State# s -> (# State# s, Char# #) -}
1963 {- should be monadic??? -}
1964 (NewByteArrayOp CharRep, simp_op (text "newarr [mscorlib]System.Byte")),
1965 (NewByteArrayOp IntRep, simp_op (text "newarr [mscorlib]System.Int32")),
1966 (NewByteArrayOp WordRep, simp_op (text "newarr [mscorlib]System.UInt32")),
1967 (NewByteArrayOp AddrRep, simp_op (text "newarr [mscorlib]System.UInt64")),
1968 (NewByteArrayOp FloatRep, simp_op (text "newarr [mscorlib]System.Single")),
1969 (NewByteArrayOp DoubleRep, simp_op (text "newarr [mscorlib]System.Double")),
1970 (NewByteArrayOp StablePtrRep, simp_op (text "newarr [mscorlib]System.UInt32")),
1971 {- (NewByteArrayOp Int64Rep, simp_op (text "newarr [mscorlib]System.Int64")), TODO: there is no unique for this one -}
1972 {- (NewByteArrayOp Word64Rep, simp_op (text "newarr [mscorlib]System.UInt64")), -}
1973 {- Int# -> State# s -> (# State# s, MutByteArr# s #) -}
1975 (UnsafeFreezeByteArrayOp, ty1_op (\ty1 -> text "nop ")),
1976 {- MutByteArr# s -> State# s -> (# State# s, ByteArr# #) -}
1977 (SizeofByteArrayOp, simp_op (text "ldlen")),
1978 {- ByteArr# -> Int# -}
1980 (SameMutableByteArrayOp, ty1_op (\ty1 -> text "ceq " <+> ilxMkBool)),
1981 {- MutByteArr# s -> MutByteArr# s -> Bool -}
1982 (SizeofMutableByteArrayOp, ty1_op (\ty1 -> text "ldlen")),
1983 {- MutByteArr# s -> Int# -}
1985 (SameMutVarOp, ty2_op (\ty1 ty2 -> text "ceq " <+> ilxMkBool)),
1986 {- MutVar# s a -> MutVar# s a -> Bool -}
1987 (NewMutVarOp, ty2_op (\ty1 ty2 -> text "newobj void" <+> repMutVar ty1 ty2 <+> text "::.ctor(!0)")),
1988 {- a -> State# s -> (# State# s, MutVar# s a #) -}
1989 (ReadMutVarOp, ty2_op (\ty1 ty2 -> text "ldfld !0" <+> repMutVar ty1 ty2 <+> text "::contents")),
1990 {- MutVar# s a -> State# s -> (# State# s, a #) -}
1991 (WriteMutVarOp, ty2_op (\ty1 ty2 -> text "stfld !0" <+> repMutVar ty1 ty2 <+> text "::contents")),
1992 {- MutVar# s a -> a -> State# s -> State# s -}
1994 (NewArrayOp, ty2_op (\ty1 ty2 -> text "call !!0[] " <+> ilxSupportClass <+> text "::newArray<" <> ty1 <> text ">(" <> repInt <> text ", !!0)")),
1995 {- Int# -> a -> State# s -> (# State# s, MutArr# s a #) -}
1996 (IndexArrayOp, ty1_op (\ty1 -> text "ldelem.ref")),
1997 {- Array# a -> Int# -> (# a #) -}
1998 (WriteArrayOp, ty2_op (\ty1 ty2 -> text "stelem.ref")),
1999 {- MutArr# s a -> Int# -> a -> State# s -> State# s -}
2000 (ReadArrayOp, ty2_op (\ty1 ty2 -> text "ldelem.ref")),
2001 {- MutArr# s a -> Int# -> State# s -> (# State# s, a #) -}
2002 (UnsafeFreezeArrayOp, ty2_op (\ty1 ty2 -> text "nop")),
2003 {- MutArr# s a -> State# s -> (# State# s, Array# a #) -}
2004 (UnsafeThawArrayOp, ty2_op (\ty1 ty2 -> text "nop")),
2005 {- Array# a -> State# s -> (# State# s, MutArr# s a #) -}
2007 (SameMutableArrayOp, ty2_op (\ty1 ty2 -> text "ceq " <+> ilxMkBool)),
2008 {- MutArr# s a -> MutArr# s a -> Bool -}
2010 (MakeStablePtrOp, ty1_op (\ty1 -> text "newobj void class " <+> prelGHCReference <+> text "PrelGHC_StablePtrzh<" <> ty1 <> text ">::.ctor(!0)")),
2011 {- a -> State# RealWorld -> (# State# RealWorld, StablePtr# a #) -}
2013 (DeRefStablePtrOp, ty1_op (\ty1 -> text "ldfld !0 class " <+> prelGHCReference <+> text "PrelGHC_StablePtrzh<" <> ty1 <> text ">::contents")),
2014 {- StablePtr# a -> State# RealWorld -> (# State# RealWorld, a #) -}
2016 (EqStablePtrOp, ty1_op (\ty1 -> text "ceq " <+> ilxMkBool)),
2017 {- StablePtr# a -> StablePtr# a -> Int# -}
2019 (MkWeakOp, ty3_op (\ty1 ty2 ty3 -> text "call" <+> ilxMethodRef (repWeak (text "!!1")) (text "class " <+> prelGHCReference <+> text "PrelGHC_Weakzh") "bake" [ty1,ty2,ty3] [text "!!0", text "!!1", text "!!2"])),
2020 {- o -> b -> c -> State# RealWorld -> (# State# RealWorld, Weak# b #) -}
2022 (DeRefWeakOp, ty1_op (\ty1 -> text "call" <+> ilxMethodRef (ilxUnboxedPairRep repInt (text "!0")) (repWeak ty1) "deref" [] [])),
2023 (FinalizeWeakOp, ty1_op (\ty1 -> text "call" <+> ilxMethodRef (ilxUnboxedPairRep repInt (text "(func () --> class '()')")) (repWeak ty1) "finalizer" [] [])),
2024 {- Weak# a -> State# RealWorld -> (# State# RealWorld, Int#,
2025 (State# RealWorld -> (# State# RealWorld, Unit #)) #) -}
2027 (MkForeignObjOp, simp_op (text "nop /* newobj void class " <+> prelGHCReference <+> text "PrelGHC_ForeignObjzh::.ctor(void *) */")),
2028 (WriteForeignObjOp, simp_op (text "pop /* stfld void * class " <+> prelGHCReference <+> text "PrelGHC_ForeignObjzh::contents */ ")),
2029 -- (ForeignObjToAddrOp, simp_op (text "ldfld void * class " <+> prelGHCReference <+> text "PrelGHC_ForeignObjzh::contents"),
2030 (YieldOp, simp_op (text "call class [mscorlib]System.Threading.Thread class [mscorlib]System.Threading.Thread::get_CurrentThread()
2031 call void class [mscorlib]System.Threading.Thread::Suspend()")),
2032 (MyThreadIdOp, simp_op (text "call default class [mscorlib]System.Threading.Thread class [mscorlib]System.Threading.Thread::get_CurrentThread() ")),
2033 (KillThreadOp, simp_op (text "call instance void class [mscorlib]System.Threading.Thread::Abort(class [mscorlib]System.Object) ")),
2034 {- ThreadId# -> a -> State# RealWorld -> State# RealWorld -}
2036 (ForkOp, ty1_op (\ty -> text "call default class [mscorlib]System.Threading.Thread " <+> ilxSupportClass <+> text "::fork<" <> ty <> text ">(thunk<!0>)")),
2038 (ParOp, warn_op "ParOp" (simp_op (text "/* ParOp skipped... */ pop ldc.i4 0"))),
2040 (DelayOp, simp_op (text "call void class [mscorlib]System.Threading.Thread::Sleep(int32) ")),
2041 {- Int# -> State# s -> State# s -}
2042 (WaitReadOp, warn_op "WaitReadOp" (simp_op (text "/* WaitReadOp skipped... */ pop"))),
2043 (WaitWriteOp, warn_op "WaitWriteOp" (simp_op (text " /* WaitWriteOp skipped... */ pop")))
2049 ty1_op op env ((StgTypeArg ty1):rest) =
2050 vcat (ilxMapPlaceArgs 1 pushArg env rest) $$ op (pprIlxTypeR env (deepIlxRepType ty1))
2051 --ty1_after1_op op env (h:(StgTypeArg ty1):rest) =
2052 -- vcat (ilxMapPlaceArgs 0 pushArg env [h]) $$ vcat (ilxMapPlaceArgs 2 pushArg env rest) $$ op (pprIlxTypeR env (deepIlxRepType ty1))
2053 ty2_op op env ((StgTypeArg ty1):(StgTypeArg ty2):rest) =
2054 vcat (ilxMapPlaceArgs 2 pushArg env rest) $$ op (pprIlxTypeR env (deepIlxRepType ty1)) (pprIlxTypeR env (deepIlxRepType ty2))
2056 ty3_op op env ((StgTypeArg ty1):(StgTypeArg ty2):(StgTypeArg ty3):rest) =
2057 vcat (ilxMapPlaceArgs 2 pushArg env rest) $$
2058 op (pprIlxTypeR env (deepIlxRepType ty1))
2059 (pprIlxTypeR env (deepIlxRepType ty2))
2060 (pprIlxTypeR env (deepIlxRepType ty3))
2062 ty1_arg4_op op env [(StgTypeArg ty1), a1, a2, a3, a4] =
2063 op (pprIlxTypeR env (deepIlxRepType ty1))
2064 (hd2 (ilxMapPlaceArgs 1 pushArg env [a1]) )
2065 (hd2 (ilxMapPlaceArgs 2 pushArg env [a2]) )
2066 (hd2 (ilxMapPlaceArgs 3 pushArg env [a3]) )
2067 (hd2 (ilxMapPlaceArgs 4 pushArg env [a4]) )
2072 simp_op op env args = vcat (ilxMapPlaceArgs 0 pushArg env args) $$ op
2073 warn_op warning f args = trace ("WARNING! IlxGen cannot translate primop " ++ warning) (f args)