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