ghc/compiler/ilxGen/IlxGen.lhs

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