ghc/compiler/ilxGen/IlxGen.lhs

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