compiler/ilxGen/IlxGen.lhs

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