ghc/compiler/ghci/StgInterp.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-2000
   3 %
   4 \section[StgInterp]{Translates STG syntax to interpretable form, and run it}
   5
   6 \begin{code}
   7
   8 module StgInterp (
   9
  10     ClosureEnv, ItblEnv,
  11     filterRdrNameEnv,   -- :: [ModuleName] -> FiniteMap RdrName a
  12                         -- -> FiniteMap RdrName a
  13
  14     linkIModules,       -- :: ItblEnv -> ClosureEnv
  15                         -- -> [([UnlinkedIBind], ItblEnv)]
  16                         -- -> IO ([LinkedIBind], ItblEnv, ClosureEnv)
  17
  18     iExprToHValue,      --  :: ItblEnv -> ClosureEnv
  19                         --  -> UnlinkedIExpr -> HValue
  20
  21     stgBindsToInterpSyn,-- :: [StgBinding]
  22                         -- -> [TyCon] -> [Class]
  23                         -- -> IO ([UnlinkedIBind], ItblEnv)
  24
  25     stgExprToInterpSyn, -- :: StgExpr
  26                         -- -> IO UnlinkedIExpr
  27
  28     interp              -- :: LinkedIExpr -> HValue
  29  ) where
  30
  31 {- -----------------------------------------------------------------------------
  32
  33  ToDo:
  34    - link should be in the IO monad, so it can modify the symtabs as it
  35      goes along
  36
  37    - need a way to remove the bindings for a module from the symtabs.
  38      maybe the symtabs should be indexed by module first.
  39
  40    - change the representation to something less verbose (?).
  41
  42    - converting string literals to Addr# is horrible and introduces
  43      a memory leak.  See if something can be done about this.
  44
  45 ----------------------------------------------------------------------------- -}
  46
  47 #include "HsVersions.h"
  48
  49 import Linker
  50 import Id               ( Id, idPrimRep )
  51 import Outputable
  52 import Var
  53 import PrimOp           ( PrimOp(..) )
  54 import PrimRep          ( PrimRep(..) )
  55 import Literal          ( Literal(..) )
  56 import Type             ( Type, typePrimRep, deNoteType, repType, funResultTy )
  57 import DataCon          ( DataCon, dataConTag, dataConRepArgTys )
  58 import ClosureInfo      ( mkVirtHeapOffsets )
  59 import Module           ( ModuleName )
  60 import Name             ( toRdrName )
  61 import UniqFM
  62 import UniqSet
  63
  64 import {-# SOURCE #-} MCI_make_constr
  65
  66 import IOExts           ( unsafePerformIO ) -- ToDo: remove
  67 import PrelGHC          --( unsafeCoerce#, dataToTag#,
  68                         --  indexPtrOffClosure#, indexWordOffClosure# )
  69 import PrelAddr         ( Addr(..) )
  70 import PrelFloat        ( Float(..), Double(..) )
  71 import Bits
  72 import FastString
  73 import GlaExts          ( Int(..) )
  74 import Module           ( moduleNameFS )
  75
  76 import TyCon            ( TyCon, isDataTyCon, tyConDataCons, tyConFamilySize )
  77 import Class            ( Class, classTyCon )
  78 import InterpSyn
  79 import StgSyn
  80 import Addr
  81 import RdrName          ( RdrName, rdrNameModule, rdrNameOcc )
  82 import FiniteMap
  83 import Panic            ( panic )
  84 import OccName          ( occNameString )
  85 import ErrUtils         ( showPass )
  86 import CmdLineOpts      ( DynFlags )
  87
  88 import Foreign
  89 import CTypes
  90 import IO
  91
  92 -- ---------------------------------------------------------------------------
  93 -- Environments needed by the linker
  94 -- ---------------------------------------------------------------------------
  95
  96 type ItblEnv    = FiniteMap RdrName (Ptr StgInfoTable)
  97 type ClosureEnv = FiniteMap RdrName HValue
  98 emptyClosureEnv = emptyFM
  99
 100 -- remove all entries for a given set of modules from the environment
 101 filterRdrNameEnv :: [ModuleName] -> FiniteMap RdrName a -> FiniteMap RdrName a
 102 filterRdrNameEnv mods env
 103    = filterFM (\n _ -> rdrNameModule n `notElem` mods) env
 104
 105 -- ---------------------------------------------------------------------------
 106 -- Turn an UnlinkedIExpr into a value we can run, for the interpreter
 107 -- ---------------------------------------------------------------------------
 108
 109 iExprToHValue :: ItblEnv -> ClosureEnv -> UnlinkedIExpr -> IO HValue
 110 iExprToHValue ie ce expr = return (interp (linkIExpr ie ce expr))
 111
 112 -- ---------------------------------------------------------------------------
 113 -- Convert STG to an unlinked interpretable
 114 -- ---------------------------------------------------------------------------
 115
 116 -- visible from outside
 117 stgBindsToInterpSyn :: DynFlags
 118                     -> [StgBinding]
 119                     -> [TyCon] -> [Class]
 120                     -> IO ([UnlinkedIBind], ItblEnv)
 121 stgBindsToInterpSyn dflags binds local_tycons local_classes
 122  = do showPass dflags "StgToInterp"
 123       let ibinds = concatMap (translateBind emptyUniqSet) binds
 124       let tycs   = local_tycons ++ map classTyCon local_classes
 125       itblenv <- mkITbls tycs
 126       return (ibinds, itblenv)
 127
 128 stgExprToInterpSyn :: DynFlags
 129                    -> StgExpr
 130                    -> IO UnlinkedIExpr
 131 stgExprToInterpSyn dflags expr
 132  = do showPass dflags "StgToInterp"
 133       return (stg2expr emptyUniqSet expr)
 134
 135 translateBind :: UniqSet Id -> StgBinding -> [UnlinkedIBind]
 136 translateBind ie (StgNonRec v e)  = [IBind v (rhs2expr ie e)]
 137 translateBind ie (StgRec vs_n_es) = [IBind v (rhs2expr ie' e) | (v,e) <- vs_n_es]
 138   where ie' = addListToUniqSet ie (map fst vs_n_es)
 139
 140 isRec (StgNonRec _ _) = False
 141 isRec (StgRec _)      = True
 142
 143 rhs2expr :: UniqSet Id -> StgRhs -> UnlinkedIExpr
 144 rhs2expr ie (StgRhsClosure ccs binfo srt fvs uflag args rhs)
 145    = mkLambdas args
 146      where
 147         rhsExpr = stg2expr (addListToUniqSet ie args) rhs
 148         rhsRep  = repOfStgExpr rhs
 149         mkLambdas [] = rhsExpr
 150         mkLambdas (v:vs) = mkLam (repOfId v) rhsRep v (mkLambdas vs)
 151 rhs2expr ie (StgRhsCon ccs dcon args)
 152    = conapp2expr ie dcon args
 153
 154 conapp2expr :: UniqSet Id -> DataCon -> [StgArg] -> UnlinkedIExpr
 155 conapp2expr ie dcon args
 156    = mkConApp con_rdrname reps exprs
 157      where
 158         con_rdrname = toRdrName dcon
 159         exprs       = map (arg2expr ie) inHeapOrder
 160         reps        = map repOfArg inHeapOrder
 161         inHeapOrder = toHeapOrder args
 162
 163         toHeapOrder :: [StgArg] -> [StgArg]
 164         toHeapOrder args
 165            = let (_, _, rearranged_w_offsets) = mkVirtHeapOffsets getArgPrimRep args
 166                  (rearranged, offsets) = unzip rearranged_w_offsets
 167              in
 168                  rearranged
 169
 170 foreign label "PrelBase_Izh_con_info" prelbase_Izh_con_info :: Addr
 171
 172 -- Handle most common cases specially; do the rest with a generic
 173 -- mechanism (deferred till later :)
 174 mkConApp :: RdrName -> [Rep] -> [UnlinkedIExpr] -> UnlinkedIExpr
 175 mkConApp nm []               []         = ConApp    nm
 176 mkConApp nm [RepI]           [a1]       = ConAppI   nm a1
 177 mkConApp nm [RepP]           [a1]       = ConAppP   nm a1
 178 mkConApp nm [RepP,RepP]      [a1,a2]    = ConAppPP  nm a1 a2
 179 mkConApp nm [RepP,RepP,RepP] [a1,a2,a3] = ConAppPPP nm a1 a2 a3
 180 mkConApp nm reps args
 181    = pprPanic "StgInterp.mkConApp: unhandled reps" (hsep (map ppr reps))
 182
 183 mkLam RepP RepP = LamPP
 184 mkLam RepI RepP = LamIP
 185 mkLam RepP RepI = LamPI
 186 mkLam RepI RepI = LamII
 187 mkLam repa repr = pprPanic "StgInterp.mkLam" (ppr repa <+> ppr repr)
 188
 189 mkApp RepP RepP = AppPP
 190 mkApp RepI RepP = AppIP
 191 mkApp RepP RepI = AppPI
 192 mkApp RepI RepI = AppII
 193 mkApp repa repr = pprPanic "StgInterp.mkApp" (ppr repa <+> ppr repr)
 194
 195 repOfId :: Id -> Rep
 196 repOfId = primRep2Rep . idPrimRep
 197
 198 primRep2Rep primRep
 199    = case primRep of
 200
 201         -- genuine lifted types
 202         PtrRep        -> RepP
 203
 204         -- all these are unboxed, fit into a word, and we assume they
 205         -- all have the same call/return convention.
 206         IntRep        -> RepI
 207         CharRep       -> RepI
 208         WordRep       -> RepI
 209         AddrRep       -> RepI
 210         WeakPtrRep    -> RepI
 211         StablePtrRep  -> RepI
 212
 213         -- these are pretty dodgy: really pointers, but
 214         -- we can't let the compiler build thunks with these reps.
 215         ForeignObjRep -> RepP
 216         StableNameRep -> RepP
 217         ThreadIdRep   -> RepP
 218         ArrayRep      -> RepP
 219         ByteArrayRep  -> RepP
 220
 221         FloatRep      -> RepF
 222         DoubleRep     -> RepD
 223
 224         other -> pprPanic "primRep2Rep" (ppr other)
 225
 226 repOfStgExpr :: StgExpr -> Rep
 227 repOfStgExpr stgexpr
 228    = case stgexpr of
 229         StgLit lit
 230            -> repOfLit lit
 231         StgCase scrut live liveR bndr srt alts
 232            -> case altRhss alts of
 233                  (a:_) -> repOfStgExpr a
 234                  []    -> panic "repOfStgExpr: no alts"
 235         StgApp var []
 236            -> repOfId var
 237         StgApp var args
 238            -> repOfApp ((deNoteType.repType.idType) var) (length args)
 239
 240         StgPrimApp op args res_ty
 241            -> (primRep2Rep.typePrimRep) res_ty
 242
 243         StgLet binds body -> repOfStgExpr body
 244         StgLetNoEscape live liveR binds body -> repOfStgExpr body
 245
 246         StgConApp con args -> RepP -- by definition
 247
 248         other
 249            -> pprPanic "repOfStgExpr" (ppr other)
 250      where
 251         altRhss (StgAlgAlts tycon alts def)
 252            = [rhs | (dcon,bndrs,uses,rhs) <- alts] ++ defRhs def
 253         altRhss (StgPrimAlts tycon alts def)
 254            = [rhs | (lit,rhs) <- alts] ++ defRhs def
 255         defRhs StgNoDefault
 256            = []
 257         defRhs (StgBindDefault rhs)
 258            = [rhs]
 259
 260         -- returns the Rep of the result of applying ty to n args.
 261         repOfApp :: Type -> Int -> Rep
 262         repOfApp ty 0 = (primRep2Rep.typePrimRep) ty
 263         repOfApp ty n = repOfApp (funResultTy ty) (n-1)
 264
 265
 266
 267 repOfLit lit
 268    = case lit of
 269         MachInt _    -> RepI
 270         MachWord _   -> RepI
 271         MachAddr _   -> RepI
 272         MachChar _   -> RepI
 273         MachFloat _  -> RepF
 274         MachDouble _ -> RepD
 275         MachStr _    -> RepI   -- because it's a ptr outside the heap
 276         other -> pprPanic "repOfLit" (ppr lit)
 277
 278 lit2expr :: Literal -> UnlinkedIExpr
 279 lit2expr lit
 280    = case lit of
 281         MachInt  i   -> case fromIntegral i of I# i -> LitI i
 282         MachWord i   -> case fromIntegral i of I# i -> LitI i
 283         MachAddr i   -> case fromIntegral i of I# i -> LitI i
 284         MachChar i   -> case fromIntegral i of I# i -> LitI i
 285         MachFloat f  -> case fromRational f of F# f -> LitF f
 286         MachDouble f -> case fromRational f of D# f -> LitD f
 287         MachStr s    ->
 288            case s of
 289                 CharStr s i -> LitI (addr2Int# s)
 290
 291                 FastString _ l ba ->
 292                 -- sigh, a string in the heap is no good to us.  We need a
 293                 -- static C pointer, since the type of a string literal is
 294                 -- Addr#.  So, copy the string into C land and introduce a
 295                 -- memory leak at the same time.
 296                   let n = I# l in
 297                  -- CAREFUL!  Chars are 32 bits in ghc 4.09+
 298                   case unsafePerformIO (do a@(Ptr addr) <- mallocBytes (n+1)
 299                                            strncpy a ba (fromIntegral n)
 300                                            writeCharOffAddr addr n '\0'
 301                                            return addr)
 302                   of  A# a -> LitI (addr2Int# a)
 303
 304                 _ -> error "StgInterp.lit2expr: unhandled string constant type"
 305
 306         other -> pprPanic "lit2expr" (ppr lit)
 307
 308 stg2expr :: UniqSet Id -> StgExpr -> UnlinkedIExpr
 309 stg2expr ie stgexpr
 310    = case stgexpr of
 311         StgApp var []
 312            -> mkVar ie (repOfId var) var
 313
 314         StgApp var args
 315            -> mkAppChain ie (repOfStgExpr stgexpr) (mkVar ie (repOfId var) var) args
 316         StgLit lit
 317            -> lit2expr lit
 318
 319         StgCase scrut live liveR bndr srt (StgPrimAlts ty alts def)
 320            |  repOfStgExpr scrut /= RepP
 321            -> mkCasePrim (repOfStgExpr stgexpr)
 322                          bndr (stg2expr ie scrut)
 323                               (map doPrimAlt alts)
 324                               (def2expr def)
 325
 326         StgCase scrut live liveR bndr srt (StgAlgAlts tycon alts def)
 327            |  repOfStgExpr scrut == RepP
 328            -> mkCaseAlg (repOfStgExpr stgexpr)
 329                         bndr (stg2expr ie scrut)
 330                              (map doAlgAlt alts)
 331                              (def2expr def)
 332
 333         StgPrimApp op args res_ty
 334            -> mkPrimOp (repOfStgExpr stgexpr)
 335                        op (map (arg2expr ie) args)
 336
 337         StgConApp dcon args
 338            -> conapp2expr ie dcon args
 339
 340         StgLet binds@(StgNonRec v e) body
 341            -> mkNonRec (repOfStgExpr stgexpr)
 342                 (head (translateBind ie binds))
 343                 (stg2expr (addOneToUniqSet ie v) body)
 344
 345         StgLet binds@(StgRec bs) body
 346            -> mkRec (repOfStgExpr stgexpr)
 347                 (translateBind ie binds)
 348                 (stg2expr (addListToUniqSet ie (map fst bs)) body)
 349
 350         -- treat let-no-escape just like let.
 351         StgLetNoEscape _ _ binds body
 352            -> stg2expr ie (StgLet binds body)
 353
 354         other
 355            -> pprPanic "stg2expr" (ppr stgexpr)
 356      where
 357         doPrimAlt (lit,rhs)
 358            = AltPrim (lit2expr lit) (stg2expr ie rhs)
 359         doAlgAlt (dcon,vars,uses,rhs)
 360            = AltAlg (dataConTag dcon - 1)
 361                     (map id2VaaRep (toHeapOrder vars))
 362                         (stg2expr (addListToUniqSet ie vars) rhs)
 363
 364         toHeapOrder vars
 365            = let (_,_,rearranged_w_offsets) = mkVirtHeapOffsets idPrimRep vars
 366                  (rearranged,offsets)       = unzip rearranged_w_offsets
 367              in
 368                  rearranged
 369
 370         def2expr StgNoDefault         = Nothing
 371         def2expr (StgBindDefault rhs) = Just (stg2expr ie rhs)
 372
 373         mkAppChain ie result_rep so_far []
 374            = panic "mkAppChain"
 375         mkAppChain ie result_rep so_far [a]
 376            = mkApp (repOfArg a) result_rep so_far (arg2expr ie a)
 377         mkAppChain ie result_rep so_far (a:as)
 378            = mkAppChain ie result_rep (mkApp (repOfArg a) RepP so_far (arg2expr ie a)) as
 379
 380 mkCasePrim RepI = CasePrimI
 381 mkCasePrim RepP = CasePrimP
 382
 383 mkCaseAlg  RepI = CaseAlgI
 384 mkCaseAlg  RepP = CaseAlgP
 385
 386 -- any var that isn't in scope is turned into a Native
 387 mkVar ie rep var
 388   | var `elementOfUniqSet` ie =
 389         (case rep of
 390            RepI -> VarI
 391            RepF -> VarF
 392            RepD -> VarD
 393            RepP -> VarP)  var
 394   | otherwise = Native (toRdrName var)
 395
 396 mkRec RepI = RecI
 397 mkRec RepP = RecP
 398 mkNonRec RepI = NonRecI
 399 mkNonRec RepP = NonRecP
 400
 401 mkPrimOp RepI = PrimOpI
 402 mkPrimOp RepP = PrimOpP
 403
 404 arg2expr :: UniqSet Id -> StgArg -> UnlinkedIExpr
 405 arg2expr ie (StgVarArg v)   = mkVar ie (repOfId v) v
 406 arg2expr ie (StgLitArg lit) = lit2expr lit
 407 arg2expr ie (StgTypeArg ty) = pprPanic "arg2expr" (ppr ty)
 408
 409 repOfArg :: StgArg -> Rep
 410 repOfArg (StgVarArg v)   = repOfId v
 411 repOfArg (StgLitArg lit) = repOfLit lit
 412 repOfArg (StgTypeArg ty) = pprPanic "repOfArg" (ppr ty)
 413
 414 id2VaaRep var = (var, repOfId var)
 415
 416
 417 -- ---------------------------------------------------------------------------
 418 -- Link interpretables into something we can run
 419 -- ---------------------------------------------------------------------------
 420
 421 linkIModules :: ItblEnv    -- incoming global itbl env; returned updated
 422              -> ClosureEnv -- incoming global closure env; returned updated
 423              -> [([UnlinkedIBind], ItblEnv)]
 424              -> IO ([LinkedIBind], ItblEnv, ClosureEnv)
 425 linkIModules gie gce mods = do
 426   let (bindss, ies) = unzip mods
 427       binds  = concat bindss
 428       top_level_binders = map (toRdrName.binder) binds
 429       final_gie = foldr plusFM gie ies
 430
 431   let {-rec-}
 432       new_gce = addListToFM gce (zip top_level_binders new_rhss)
 433       new_rhss = map (\b -> evalP (bindee b) emptyUFM) new_binds
 434     --vvvvvvvvv----------------------------------------^^^^^^^^^-- circular
 435       new_binds = linkIBinds final_gie new_gce binds
 436
 437   return (new_binds, final_gie, new_gce)
 438
 439
 440 -- We're supposed to augment the environments with the values of any
 441 -- external functions/info tables we need as we go along, but that's a
 442 -- lot of hassle so for now I'll look up external things as they crop
 443 -- up and not cache them in the source symbol tables.  The interpreted
 444 -- code will still be referenced in the source symbol tables.
 445
 446 linkIBinds :: ItblEnv -> ClosureEnv -> [UnlinkedIBind] -> [LinkedIBind]
 447 linkIBinds ie ce binds = map (linkIBind ie ce) binds
 448
 449 linkIBind ie ce (IBind bndr expr) = IBind bndr (linkIExpr ie ce expr)
 450
 451 linkIExpr :: ItblEnv -> ClosureEnv -> UnlinkedIExpr -> LinkedIExpr
 452 linkIExpr ie ce expr = case expr of
 453
 454    CaseAlgP  bndr expr alts dflt ->
 455         CaseAlgP bndr (linkIExpr ie ce expr) (linkAlgAlts ie ce alts)
 456                         (linkDefault ie ce dflt)
 457
 458    CaseAlgI  bndr expr alts dflt ->
 459         CaseAlgI bndr (linkIExpr ie ce expr) (linkAlgAlts ie ce alts)
 460                         (linkDefault ie ce dflt)
 461
 462    CasePrimP bndr expr alts dflt ->
 463         CasePrimP bndr (linkIExpr ie ce expr) (linkPrimAlts ie ce alts)
 464                         (linkDefault ie ce dflt)
 465
 466    CasePrimI bndr expr alts dflt ->
 467         CasePrimI bndr (linkIExpr ie ce expr) (linkPrimAlts ie ce alts)
 468                         (linkDefault ie ce dflt)
 469
 470    ConApp con ->
 471         ConApp (lookupCon ie con)
 472
 473    ConAppI   con arg0 ->
 474         ConAppI (lookupCon ie con) (linkIExpr ie ce arg0)
 475
 476    ConAppP   con arg0 ->
 477         ConAppP (lookupCon ie con) (linkIExpr ie ce arg0)
 478
 479    ConAppPP  con arg0 arg1 ->
 480         ConAppPP (lookupCon ie con) (linkIExpr ie ce arg0) (linkIExpr ie ce arg1)
 481
 482    ConAppPPP con arg0 arg1 arg2 ->
 483         ConAppPPP (lookupCon ie con) (linkIExpr ie ce arg0)
 484                         (linkIExpr ie ce arg1) (linkIExpr ie ce arg2)
 485
 486    PrimOpI op args -> PrimOpI op (map (linkIExpr ie ce) args)
 487    PrimOpP op args -> PrimOpP op (map (linkIExpr ie ce) args)
 488
 489    NonRecP bind expr  -> NonRecP (linkIBind ie ce bind) (linkIExpr ie ce expr)
 490    RecP    binds expr -> RecP (linkIBinds ie ce binds) (linkIExpr ie ce expr)
 491
 492    NonRecI bind expr  -> NonRecI (linkIBind ie ce bind) (linkIExpr ie ce expr)
 493    RecI    binds expr -> RecI (linkIBinds ie ce binds) (linkIExpr ie ce expr)
 494
 495    LitI i -> LitI i
 496    LitF i -> LitF i
 497    LitD i -> LitD i
 498
 499    Native var -> lookupNative ce var
 500
 501    VarP v -> lookupVar ce VarP v
 502    VarI v -> lookupVar ce VarI v
 503
 504    LamPP  bndr expr -> LamPP bndr (linkIExpr ie ce expr)
 505    LamPI  bndr expr -> LamPI bndr (linkIExpr ie ce expr)
 506    LamIP  bndr expr -> LamIP bndr (linkIExpr ie ce expr)
 507    LamII  bndr expr -> LamII bndr (linkIExpr ie ce expr)
 508
 509    AppPP  fun arg -> AppPP (linkIExpr ie ce fun) (linkIExpr ie ce arg)
 510    AppPI  fun arg -> AppPI (linkIExpr ie ce fun) (linkIExpr ie ce arg)
 511    AppIP  fun arg -> AppIP (linkIExpr ie ce fun) (linkIExpr ie ce arg)
 512    AppII  fun arg -> AppII (linkIExpr ie ce fun) (linkIExpr ie ce arg)
 513
 514 lookupCon ie con =
 515   case lookupFM ie con of
 516     Just (Ptr addr) -> addr
 517     Nothing   ->
 518         -- try looking up in the object files.
 519         case {-HACK!!!-}
 520                 unsafePerformIO (lookupSymbol (rdrNameToCLabel con "con_info")) of
 521             Just addr -> addr
 522             Nothing   -> pprPanic "linkIExpr" (ppr con)
 523
 524 lookupNative ce var =
 525   case lookupFM ce var of
 526     Just e  -> Native e
 527     Nothing ->
 528         -- try looking up in the object files.
 529         let lbl = (rdrNameToCLabel var "closure")
 530             addr = unsafePerformIO (lookupSymbol lbl) in
 531         case {- trace (lbl ++ " -> " ++ show addr) $ -} addr of
 532             Just (A# addr) -> Native (unsafeCoerce# addr)
 533             Nothing   -> pprPanic "linkIExpr" (ppr var)
 534
 535 -- some VarI/VarP refer to top-level interpreted functions; we change
 536 -- them into Natives here.
 537 lookupVar ce f v =
 538   case lookupFM ce (toRdrName v) of
 539         Nothing -> f v
 540         Just e  -> Native e
 541
 542 -- HACK!!!  ToDo: cleaner
 543 rdrNameToCLabel :: RdrName -> String{-suffix-} -> String
 544 rdrNameToCLabel rn suffix =
 545   _UNPK_(moduleNameFS (rdrNameModule rn))
 546   ++ '_':occNameString(rdrNameOcc rn) ++ '_':suffix
 547
 548 linkAlgAlts ie ce = map (linkAlgAlt ie ce)
 549 linkAlgAlt ie ce (AltAlg tag args rhs) = AltAlg tag args (linkIExpr ie ce rhs)
 550
 551 linkPrimAlts ie ce = map (linkPrimAlt ie ce)
 552 linkPrimAlt ie ce (AltPrim lit rhs)
 553    = AltPrim (linkIExpr ie ce lit) (linkIExpr ie ce rhs)
 554
 555 linkDefault ie ce Nothing = Nothing
 556 linkDefault ie ce (Just expr) = Just (linkIExpr ie ce expr)
 557
 558 -- ---------------------------------------------------------------------------
 559 -- The interpreter proper
 560 -- ---------------------------------------------------------------------------
 561
 562 -- The dynamic environment contains everything boxed.
 563 -- eval* functions which look up values in it will know the
 564 -- representation of the thing they are looking up, so they
 565 -- can cast/unbox it as necessary.
 566
 567 -- ---------------------------------------------------------------------------
 568 -- Evaluator for things of boxed (pointer) representation
 569 -- ---------------------------------------------------------------------------
 570
 571 interp :: LinkedIExpr -> HValue
 572 interp iexpr = unsafeCoerce# (evalP iexpr emptyUFM)
 573
 574 evalP :: LinkedIExpr -> UniqFM boxed -> boxed
 575
 576 {-
 577 evalP expr de
 578 --   | trace ("evalP: " ++ showExprTag expr) False
 579    | trace ("evalP:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
 580    = error "evalP: ?!?!"
 581 -}
 582
 583 evalP (Native p) de  = unsafeCoerce# p
 584
 585 -- First try the dynamic env.  If that fails, assume it's a top-level
 586 -- binding and look in the static env.  That gives an Expr, which we
 587 -- must convert to a boxed thingy by applying evalP to it.  Because
 588 -- top-level bindings are always ptr-rep'd (either lambdas or boxed
 589 -- CAFs), it's always safe to use evalP.
 590 evalP (VarP v) de
 591    = case lookupUFM de v of
 592         Just xx -> xx
 593         Nothing -> error ("evalP: lookupUFM " ++ show v)
 594
 595 -- Deal with application of a function returning a pointer rep
 596 -- to arguments of any persuasion.  Note that the function itself
 597 -- always has pointer rep.
 598 evalP (AppIP e1 e2) de  = unsafeCoerce# (evalP e1 de) (evalI e2 de)
 599 evalP (AppPP e1 e2) de  = unsafeCoerce# (evalP e1 de) (evalP e2 de)
 600 evalP (AppFP e1 e2) de  = unsafeCoerce# (evalF e1 de) (evalI e2 de)
 601 evalP (AppDP e1 e2) de  = unsafeCoerce# (evalD e1 de) (evalP e2 de)
 602
 603 -- Lambdas always return P-rep, but we need to do different things
 604 -- depending on both the argument and result representations.
 605 evalP (LamPP x b) de
 606    = unsafeCoerce# (\ xP -> evalP b (addToUFM de x xP))
 607 evalP (LamPI x b) de
 608    = unsafeCoerce# (\ xP -> evalI b (addToUFM de x xP))
 609 evalP (LamPF x b) de
 610    = unsafeCoerce# (\ xP -> evalF b (addToUFM de x xP))
 611 evalP (LamPD x b) de
 612    = unsafeCoerce# (\ xP -> evalD b (addToUFM de x xP))
 613 evalP (LamIP x b) de
 614    = unsafeCoerce# (\ xI -> evalP b (addToUFM de x (unsafeCoerce# (I# xI))))
 615 evalP (LamII x b) de
 616    = unsafeCoerce# (\ xI -> evalI b (addToUFM de x (unsafeCoerce# (I# xI))))
 617 evalP (LamIF x b) de
 618    = unsafeCoerce# (\ xI -> evalF b (addToUFM de x (unsafeCoerce# (I# xI))))
 619 evalP (LamID x b) de
 620    = unsafeCoerce# (\ xI -> evalD b (addToUFM de x (unsafeCoerce# (I# xI))))
 621 evalP (LamFP x b) de
 622    = unsafeCoerce# (\ xI -> evalP b (addToUFM de x (unsafeCoerce# (F# xI))))
 623 evalP (LamFI x b) de
 624    = unsafeCoerce# (\ xI -> evalI b (addToUFM de x (unsafeCoerce# (F# xI))))
 625 evalP (LamFF x b) de
 626    = unsafeCoerce# (\ xI -> evalF b (addToUFM de x (unsafeCoerce# (F# xI))))
 627 evalP (LamFD x b) de
 628    = unsafeCoerce# (\ xI -> evalD b (addToUFM de x (unsafeCoerce# (F# xI))))
 629 evalP (LamDP x b) de
 630    = unsafeCoerce# (\ xI -> evalP b (addToUFM de x (unsafeCoerce# (D# xI))))
 631 evalP (LamDI x b) de
 632    = unsafeCoerce# (\ xI -> evalI b (addToUFM de x (unsafeCoerce# (D# xI))))
 633 evalP (LamDF x b) de
 634    = unsafeCoerce# (\ xI -> evalF b (addToUFM de x (unsafeCoerce# (D# xI))))
 635 evalP (LamDD x b) de
 636    = unsafeCoerce# (\ xI -> evalD b (addToUFM de x (unsafeCoerce# (D# xI))))
 637
 638
 639 -- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps,
 640 -- except in the sense that we go on and evaluate the body with whichever
 641 -- evaluator was used for the expression as a whole.
 642 evalP (NonRecP bind e) de
 643    = evalP e (augment_nonrec bind de)
 644 evalP (RecP binds b) de
 645    = evalP b (augment_rec binds de)
 646 evalP (CaseAlgP bndr expr alts def) de
 647    = case helper_caseAlg bndr expr alts def de of
 648         (rhs, de') -> evalP rhs de'
 649 evalP (CasePrimP bndr expr alts def) de
 650    = case helper_casePrim bndr expr alts def de of
 651         (rhs, de') -> evalP rhs de'
 652
 653 {-
 654 -- ConApp can only be handled by evalP
 655 evalP (ConApp itbl args) se de
 656    = loop args
 657      where
 658         -- This appalling hack suggested (gleefully) by SDM
 659         -- It is not well typed (needless to say?)
 660         loop :: [Expr] -> boxed
 661         loop []
 662            = trace "loop-empty" (
 663              case itbl of A# addr# -> unsafeCoerce# (mci_make_constr addr#)
 664              )
 665         loop (a:as)
 666            = trace "loop-not-empty" (
 667              case repOf a of
 668                 RepI -> case evalI a de of i# -> loop as i#
 669                 RepP -> let p = evalP a de in loop as p
 670              )
 671 -}
 672
 673 evalP (ConAppI (A# itbl) a1) de
 674    = case evalI a1 de of i1 -> mci_make_constrI itbl i1
 675
 676 evalP (ConApp (A# itbl)) de
 677    = mci_make_constr itbl
 678
 679 evalP (ConAppP (A# itbl) a1) de
 680    = let p1 = evalP a1 de
 681      in  mci_make_constrP itbl p1
 682
 683 evalP (ConAppPP (A# itbl) a1 a2) de
 684    = let p1 = evalP a1 de
 685          p2 = evalP a2 de
 686      in  mci_make_constrPP itbl p1 p2
 687
 688 evalP (ConAppPPP (A# itbl) a1 a2 a3) de
 689    = let p1 = evalP a1 de
 690          p2 = evalP a2 de
 691          p3 = evalP a3 de
 692      in  mci_make_constrPPP itbl p1 p2 p3
 693
 694
 695
 696 evalP other de
 697    = error ("evalP: unhandled case: " ++ showExprTag other)
 698
 699 --------------------------------------------------------
 700 --- Evaluator for things of Int# representation
 701 --------------------------------------------------------
 702
 703 -- Evaluate something which has an unboxed Int rep
 704 evalI :: LinkedIExpr -> UniqFM boxed -> Int#
 705
 706 {-
 707 evalI expr de
 708 --   | trace ("evalI: " ++ showExprTag expr) False
 709    | trace ("evalI:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
 710    = error "evalI: ?!?!"
 711 -}
 712
 713 evalI (LitI i#) de = i#
 714
 715 evalI (VarI v) de =
 716    case lookupUFM de v of
 717         Just e  -> case unsafeCoerce# e of I# i -> i
 718         Nothing -> error ("evalI: lookupUFM " ++ show v)
 719
 720 -- Deal with application of a function returning an Int# rep
 721 -- to arguments of any persuasion.  Note that the function itself
 722 -- always has pointer rep.
 723 evalI (AppII e1 e2) de
 724    = unsafeCoerce# (evalP e1 de) (evalI e2 de)
 725 evalI (AppPI e1 e2) de
 726    = unsafeCoerce# (evalP e1 de) (evalP e2 de)
 727 evalI (AppFI e1 e2) de
 728    = unsafeCoerce# (evalP e1 de) (evalF e2 de)
 729 evalI (AppDI e1 e2) de
 730    = unsafeCoerce# (evalP e1 de) (evalD e2 de)
 731
 732 -- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps,
 733 -- except in the sense that we go on and evaluate the body with whichever
 734 -- evaluator was used for the expression as a whole.
 735 evalI (NonRecI bind b) de
 736    = evalI b (augment_nonrec bind de)
 737 evalI (RecI binds b) de
 738    = evalI b (augment_rec binds de)
 739 evalI (CaseAlgI bndr expr alts def) de
 740    = case helper_caseAlg bndr expr alts def de of
 741         (rhs, de') -> evalI rhs de'
 742 evalI (CasePrimI bndr expr alts def) de
 743    = case helper_casePrim bndr expr alts def de of
 744         (rhs, de') -> evalI rhs de'
 745
 746 -- evalI can't be applied to a lambda term, by defn, since those
 747 -- are ptr-rep'd.
 748
 749 evalI (PrimOpI IntAddOp [e1,e2]) de  = evalI e1 de +# evalI e2 de
 750 evalI (PrimOpI IntSubOp [e1,e2]) de  = evalI e1 de -# evalI e2 de
 751
 752 --evalI (NonRec (IBind v e) b) de
 753 --   = evalI b (augment de v (eval e de))
 754
 755 evalI other de
 756    = error ("evalI: unhandled case: " ++ showExprTag other)
 757
 758 --------------------------------------------------------
 759 --- Evaluator for things of Float# representation
 760 --------------------------------------------------------
 761
 762 -- Evaluate something which has an unboxed Int rep
 763 evalF :: LinkedIExpr -> UniqFM boxed -> Float#
 764
 765 {-
 766 evalF expr de
 767 --   | trace ("evalF: " ++ showExprTag expr) False
 768    | trace ("evalF:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
 769    = error "evalF: ?!?!"
 770 -}
 771
 772 evalF (LitF f#) de = f#
 773
 774 evalF (VarF v) de =
 775    case lookupUFM de v of
 776         Just e  -> case unsafeCoerce# e of F# i -> i
 777         Nothing -> error ("evalF: lookupUFM " ++ show v)
 778
 779 -- Deal with application of a function returning an Int# rep
 780 -- to arguments of any persuasion.  Note that the function itself
 781 -- always has pointer rep.
 782 evalF (AppIF e1 e2) de
 783    = unsafeCoerce# (evalP e1 de) (evalI e2 de)
 784 evalF (AppPF e1 e2) de
 785    = unsafeCoerce# (evalP e1 de) (evalP e2 de)
 786 evalF (AppFF e1 e2) de
 787    = unsafeCoerce# (evalP e1 de) (evalF e2 de)
 788 evalF (AppDF e1 e2) de
 789    = unsafeCoerce# (evalP e1 de) (evalD e2 de)
 790
 791 -- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps,
 792 -- except in the sense that we go on and evaluate the body with whichever
 793 -- evaluator was used for the expression as a whole.
 794 evalF (NonRecF bind b) de
 795    = evalF b (augment_nonrec bind de)
 796 evalF (RecF binds b) de
 797    = evalF b (augment_rec binds de)
 798 evalF (CaseAlgF bndr expr alts def) de
 799    = case helper_caseAlg bndr expr alts def de of
 800         (rhs, de') -> evalF rhs de'
 801 evalF (CasePrimF bndr expr alts def) de
 802    = case helper_casePrim bndr expr alts def de of
 803         (rhs, de') -> evalF rhs de'
 804
 805 -- evalF can't be applied to a lambda term, by defn, since those
 806 -- are ptr-rep'd.
 807
 808 evalF (PrimOpF op _) de
 809   = error ("evalF: unhandled primop: " ++ showSDoc (ppr op))
 810
 811 evalF other de
 812   = error ("evalF: unhandled case: " ++ showExprTag other)
 813
 814 --------------------------------------------------------
 815 --- Evaluator for things of Double# representation
 816 --------------------------------------------------------
 817
 818 -- Evaluate something which has an unboxed Int rep
 819 evalD :: LinkedIExpr -> UniqFM boxed -> Double#
 820
 821 {-
 822 evalD expr de
 823 --   | trace ("evalD: " ++ showExprTag expr) False
 824    | trace ("evalD:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
 825    = error "evalD: ?!?!"
 826 -}
 827
 828 evalD (LitD d#) de = d#
 829
 830 evalD (VarD v) de =
 831    case lookupUFM de v of
 832         Just e  -> case unsafeCoerce# e of D# i -> i
 833         Nothing -> error ("evalD: lookupUFM " ++ show v)
 834
 835 -- Deal with application of a function returning an Int# rep
 836 -- to arguments of any persuasion.  Note that the function itself
 837 -- always has pointer rep.
 838 evalD (AppID e1 e2) de
 839    = unsafeCoerce# (evalP e1 de) (evalI e2 de)
 840 evalD (AppPD e1 e2) de
 841    = unsafeCoerce# (evalP e1 de) (evalP e2 de)
 842 evalD (AppFD e1 e2) de
 843    = unsafeCoerce# (evalP e1 de) (evalF e2 de)
 844 evalD (AppDD e1 e2) de
 845    = unsafeCoerce# (evalP e1 de) (evalD e2 de)
 846
 847 -- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps,
 848 -- except in the sense that we go on and evaluate the body with whichever
 849 -- evaluator was used for the expression as a whole.
 850 evalD (NonRecD bind b) de
 851    = evalD b (augment_nonrec bind de)
 852 evalD (RecD binds b) de
 853    = evalD b (augment_rec binds de)
 854 evalD (CaseAlgD bndr expr alts def) de
 855    = case helper_caseAlg bndr expr alts def de of
 856         (rhs, de') -> evalD rhs de'
 857 evalD (CasePrimD bndr expr alts def) de
 858    = case helper_casePrim bndr expr alts def de of
 859         (rhs, de') -> evalD rhs de'
 860
 861 -- evalD can't be applied to a lambda term, by defn, since those
 862 -- are ptr-rep'd.
 863
 864 evalD (PrimOpD op _) de
 865   = error ("evalD: unhandled primop: " ++ showSDoc (ppr op))
 866
 867 evalD other de
 868   = error ("evalD: unhandled case: " ++ showExprTag other)
 869
 870 --------------------------------------------------------
 871 --- Helper bits and pieces
 872 --------------------------------------------------------
 873
 874 -- Find the Rep of any Expr
 875 repOf :: LinkedIExpr -> Rep
 876
 877 repOf (LamPP _ _)      = RepP
 878 repOf (LamPI _ _)      = RepP
 879 repOf (LamPF _ _)      = RepP
 880 repOf (LamPD _ _)      = RepP
 881 repOf (LamIP _ _)      = RepP
 882 repOf (LamII _ _)      = RepP
 883 repOf (LamIF _ _)      = RepP
 884 repOf (LamID _ _)      = RepP
 885 repOf (LamFP _ _)      = RepP
 886 repOf (LamFI _ _)      = RepP
 887 repOf (LamFF _ _)      = RepP
 888 repOf (LamFD _ _)      = RepP
 889 repOf (LamDP _ _)      = RepP
 890 repOf (LamDI _ _)      = RepP
 891 repOf (LamDF _ _)      = RepP
 892 repOf (LamDD _ _)      = RepP
 893
 894 repOf (AppPP _ _)      = RepP
 895 repOf (AppPI _ _)      = RepI
 896 repOf (AppPF _ _)      = RepF
 897 repOf (AppPD _ _)      = RepD
 898 repOf (AppIP _ _)      = RepP
 899 repOf (AppII _ _)      = RepI
 900 repOf (AppIF _ _)      = RepF
 901 repOf (AppID _ _)      = RepD
 902 repOf (AppFP _ _)      = RepP
 903 repOf (AppFI _ _)      = RepI
 904 repOf (AppFF _ _)      = RepF
 905 repOf (AppFD _ _)      = RepD
 906 repOf (AppDP _ _)      = RepP
 907 repOf (AppDI _ _)      = RepI
 908 repOf (AppDF _ _)      = RepF
 909 repOf (AppDD _ _)      = RepD
 910
 911 repOf (NonRecP _ _)    = RepP
 912 repOf (NonRecI _ _)    = RepI
 913 repOf (NonRecF _ _)    = RepF
 914 repOf (NonRecD _ _)    = RepD
 915
 916 repOf (LitI _)         = RepI
 917 repOf (LitF _)         = RepF
 918 repOf (LitD _)         = RepD
 919
 920 repOf (VarP _)         = RepI
 921 repOf (VarI _)         = RepI
 922 repOf (VarF _)         = RepF
 923 repOf (VarD _)         = RepD
 924
 925 repOf (PrimOpP _ _)    = RepP
 926 repOf (PrimOpI _ _)    = RepI
 927 repOf (PrimOpF _ _)    = RepF
 928 repOf (PrimOpD _ _)    = RepD
 929
 930 repOf (ConApp _)       = RepP
 931 repOf (ConAppI _ _)    = RepP
 932 repOf (ConAppP _ _)    = RepP
 933 repOf (ConAppPP _ _ _) = RepP
 934 repOf (ConAppPPP _ _ _ _) = RepP
 935
 936 repOf (CaseAlgP _ _ _ _) = RepP
 937 repOf (CaseAlgI _ _ _ _) = RepI
 938 repOf (CaseAlgF _ _ _ _) = RepF
 939 repOf (CaseAlgD _ _ _ _) = RepD
 940
 941 repOf (CasePrimP _ _ _ _) = RepP
 942 repOf (CasePrimI _ _ _ _) = RepI
 943 repOf (CasePrimF _ _ _ _) = RepF
 944 repOf (CasePrimD _ _ _ _) = RepD
 945
 946 repOf other
 947    = error ("repOf: unhandled case: " ++ showExprTag other)
 948
 949 -- how big (in words) is one of these
 950 repSizeW :: Rep -> Int
 951 repSizeW RepI = 1
 952 repSizeW RepP = 1
 953
 954
 955 -- Evaluate an expression, using the appropriate evaluator,
 956 -- then box up the result.  Note that it's only safe to use this
 957 -- to create values to put in the environment.  You can't use it
 958 -- to create a value which might get passed to native code since that
 959 -- code will have no idea that unboxed things have been boxed.
 960 eval :: LinkedIExpr -> UniqFM boxed -> boxed
 961 eval expr de
 962    = case repOf expr of
 963         RepI -> unsafeCoerce# (I# (evalI expr de))
 964         RepP -> evalP expr de
 965         RepF -> unsafeCoerce# (F# (evalF expr de))
 966         RepD -> unsafeCoerce# (D# (evalD expr de))
 967
 968 -- Evaluate the scrutinee of a case, select an alternative,
 969 -- augment the environment appropriately, and return the alt
 970 -- and the augmented environment.
 971 helper_caseAlg :: Id -> LinkedIExpr -> [LinkedAltAlg] -> Maybe LinkedIExpr
 972                   -> UniqFM boxed
 973                   -> (LinkedIExpr, UniqFM boxed)
 974 helper_caseAlg bndr expr alts def de
 975    = let exprEv = evalP expr de
 976      in
 977      exprEv `seq` -- vitally important; otherwise exprEv is never eval'd
 978      case select_altAlg (tagOf exprEv) alts def of
 979         (vars,rhs) -> (rhs, augment_from_constr (addToUFM de bndr exprEv)
 980                                                 exprEv (vars,1))
 981
 982 helper_casePrim :: Var -> LinkedIExpr -> [LinkedAltPrim] -> Maybe LinkedIExpr
 983                    -> UniqFM boxed
 984                    -> (LinkedIExpr, UniqFM boxed)
 985 helper_casePrim bndr expr alts def de
 986    = case repOf expr of
 987         -- Umm, can expr have any other rep?  Yes ...
 988         -- CharRep, DoubleRep, FloatRep.  What about string reps?
 989         RepI -> case evalI expr de of
 990                    i# -> (select_altPrim alts def (LitI i#),
 991                           addToUFM de bndr (unsafeCoerce# (I# i#)))
 992
 993
 994 augment_from_constr :: UniqFM boxed -> a -> ([(Id,Rep)],Int) -> UniqFM boxed
 995 augment_from_constr de con ([],offset)
 996    = de
 997 augment_from_constr de con ((v,rep):vs,offset)
 998    = let v_binding
 999             = case rep of
1000                  RepP -> indexPtrOffClosure con offset
1001                  RepI -> unsafeCoerce# (I# (indexIntOffClosure con offset))
1002      in
1003          augment_from_constr (addToUFM de v v_binding) con
1004                              (vs,offset + repSizeW rep)
1005
1006 -- Augment the environment for a non-recursive let.
1007 augment_nonrec :: LinkedIBind -> UniqFM boxed -> UniqFM boxed
1008 augment_nonrec (IBind v e) de  = addToUFM de v (eval e de)
1009
1010 -- Augment the environment for a recursive let.
1011 augment_rec :: [LinkedIBind] -> UniqFM boxed -> UniqFM boxed
1012 augment_rec binds de
1013    = let vars   = map binder binds
1014          rhss   = map bindee binds
1015          rhs_vs = map (\rhs -> eval rhs de') rhss
1016          de'    = addListToUFM de (zip vars rhs_vs)
1017      in
1018          de'
1019
1020 -- a must be a constructor?
1021 tagOf :: a -> Int
1022 tagOf x = I# (dataToTag# x)
1023
1024 select_altAlg :: Int -> [LinkedAltAlg] -> Maybe LinkedIExpr -> ([(Id,Rep)],LinkedIExpr)
1025 select_altAlg tag [] Nothing = error "select_altAlg: no match and no default?!"
1026 select_altAlg tag [] (Just def) = ([],def)
1027 select_altAlg tag ((AltAlg tagNo vars rhs):alts) def
1028    = if   tag == tagNo
1029      then (vars,rhs)
1030      else select_altAlg tag alts def
1031
1032 -- literal may only be a literal, not an arbitrary expression
1033 select_altPrim :: [LinkedAltPrim] -> Maybe LinkedIExpr -> LinkedIExpr -> LinkedIExpr
1034 select_altPrim [] Nothing    literal = error "select_altPrim: no match and no default?!"
1035 select_altPrim [] (Just def) literal = def
1036 select_altPrim ((AltPrim lit rhs):alts) def literal
1037    = if eqLits lit literal
1038      then rhs
1039      else select_altPrim alts def literal
1040
1041 eqLits (LitI i1#) (LitI i2#) = i1# ==# i2#
1042
1043
1044 -- a is a constructor
1045 indexPtrOffClosure :: a -> Int -> b
1046 indexPtrOffClosure con (I# offset)
1047    = case indexPtrOffClosure# con offset of (# x #) -> x
1048
1049 indexIntOffClosure :: a -> Int -> Int#
1050 indexIntOffClosure con (I# offset)
1051    = case wordToInt (W# (indexWordOffClosure# con offset)) of I# i# -> i#
1052
1053
1054 ------------------------------------------------------------------------
1055 --- Manufacturing of info tables for DataCons defined in this module ---
1056 ------------------------------------------------------------------------
1057
1058 #if __GLASGOW_HASKELL__ <= 408
1059 type ItblPtr = Addr
1060 #else
1061 type ItblPtr = Ptr StgInfoTable
1062 #endif
1063
1064 -- Make info tables for the data decls in this module
1065 mkITbls :: [TyCon] -> IO ItblEnv
1066 mkITbls [] = return emptyFM
1067 mkITbls (tc:tcs) = do itbls  <- mkITbl tc
1068                       itbls2 <- mkITbls tcs
1069                       return (itbls `plusFM` itbls2)
1070
1071 mkITbl :: TyCon -> IO ItblEnv
1072 mkITbl tc
1073 --   | trace ("TYCON: " ++ showSDoc (ppr tc)) False
1074 --   = error "?!?!"
1075    | not (isDataTyCon tc)
1076    = return emptyFM
1077    | n == length dcs  -- paranoia; this is an assertion.
1078    = make_constr_itbls dcs
1079      where
1080         dcs = tyConDataCons tc
1081         n   = tyConFamilySize tc
1082
1083 cONSTR :: Int
1084 cONSTR = 1  -- as defined in ghc/includes/ClosureTypes.h
1085
1086 -- Assumes constructors are numbered from zero, not one
1087 make_constr_itbls :: [DataCon] -> IO ItblEnv
1088 make_constr_itbls cons
1089    | length cons <= 8
1090    = do is <- mapM mk_vecret_itbl (zip cons [0..])
1091         return (listToFM is)
1092    | otherwise
1093    = do is <- mapM mk_dirret_itbl (zip cons [0..])
1094         return (listToFM is)
1095      where
1096         mk_vecret_itbl (dcon, conNo)
1097            = mk_itbl dcon conNo (vecret_entry conNo)
1098         mk_dirret_itbl (dcon, conNo)
1099            = mk_itbl dcon conNo mci_constr_entry
1100
1101         mk_itbl :: DataCon -> Int -> Addr -> IO (RdrName,ItblPtr)
1102         mk_itbl dcon conNo entry_addr
1103            = let (tot_wds, ptr_wds, _)
1104                     = mkVirtHeapOffsets typePrimRep (dataConRepArgTys dcon)
1105                  ptrs = ptr_wds
1106                  nptrs  = tot_wds - ptr_wds
1107                  itbl  = StgInfoTable {
1108                            ptrs = fromIntegral ptrs, nptrs = fromIntegral nptrs,
1109                            tipe = fromIntegral cONSTR,
1110                            srtlen = fromIntegral conNo,
1111                            code0 = fromIntegral code0, code1 = fromIntegral code1,
1112                            code2 = fromIntegral code2, code3 = fromIntegral code3,
1113                            code4 = fromIntegral code4, code5 = fromIntegral code5,
1114                            code6 = fromIntegral code6, code7 = fromIntegral code7
1115                         }
1116                  -- Make a piece of code to jump to "entry_label".
1117                  -- This is the only arch-dependent bit.
1118                  -- On x86, if entry_label has an address 0xWWXXYYZZ,
1119                  -- emit   movl $0xWWXXYYZZ,%eax  ;  jmp *%eax
1120                  -- which is
1121                  -- B8 ZZ YY XX WW FF E0
1122                  (code0,code1,code2,code3,code4,code5,code6,code7)
1123                     = (0xB8, byte 0 entry_addr_w, byte 1 entry_addr_w,
1124                              byte 2 entry_addr_w, byte 3 entry_addr_w,
1125                        0xFF, 0xE0,
1126                        0x90 {-nop-})
1127
1128                  entry_addr_w :: Word32
1129                  entry_addr_w = fromIntegral (addrToInt entry_addr)
1130              in
1131                  do addr <- malloc
1132                     putStrLn ("SIZE of itbl is " ++ show (sizeOf itbl))
1133                     putStrLn ("# ptrs  of itbl is " ++ show ptrs)
1134                     putStrLn ("# nptrs of itbl is " ++ show nptrs)
1135                     poke addr itbl
1136                     return (toRdrName dcon, addr `plusPtr` 8)
1137
1138
1139 byte :: Int -> Word32 -> Word32
1140 byte 0 w = w .&. 0xFF
1141 byte 1 w = (w `shiftR` 8) .&. 0xFF
1142 byte 2 w = (w `shiftR` 16) .&. 0xFF
1143 byte 3 w = (w `shiftR` 24) .&. 0xFF
1144
1145
1146 vecret_entry 0 = mci_constr1_entry
1147 vecret_entry 1 = mci_constr2_entry
1148 vecret_entry 2 = mci_constr3_entry
1149 vecret_entry 3 = mci_constr4_entry
1150 vecret_entry 4 = mci_constr5_entry
1151 vecret_entry 5 = mci_constr6_entry
1152 vecret_entry 6 = mci_constr7_entry
1153 vecret_entry 7 = mci_constr8_entry
1154
1155 -- entry point for direct returns for created constr itbls
1156 foreign label "stg_mci_constr_entry" mci_constr_entry :: Addr
1157 -- and the 8 vectored ones
1158 foreign label "stg_mci_constr1_entry" mci_constr1_entry :: Addr
1159 foreign label "stg_mci_constr2_entry" mci_constr2_entry :: Addr
1160 foreign label "stg_mci_constr3_entry" mci_constr3_entry :: Addr
1161 foreign label "stg_mci_constr4_entry" mci_constr4_entry :: Addr
1162 foreign label "stg_mci_constr5_entry" mci_constr5_entry :: Addr
1163 foreign label "stg_mci_constr6_entry" mci_constr6_entry :: Addr
1164 foreign label "stg_mci_constr7_entry" mci_constr7_entry :: Addr
1165 foreign label "stg_mci_constr8_entry" mci_constr8_entry :: Addr
1166
1167
1168
1169 data Constructor = Constructor Int{-ptrs-} Int{-nptrs-}
1170
1171
1172 -- Ultra-minimalist version specially for constructors
1173 data StgInfoTable = StgInfoTable {
1174    ptrs :: Word16,
1175    nptrs :: Word16,
1176    srtlen :: Word16,
1177    tipe :: Word16,
1178    code0, code1, code2, code3, code4, code5, code6, code7 :: Word8
1179 }
1180
1181
1182 instance Storable StgInfoTable where
1183
1184    sizeOf itbl
1185       = (sum . map (\f -> f itbl))
1186         [fieldSz ptrs, fieldSz nptrs, fieldSz srtlen, fieldSz tipe,
1187          fieldSz code0, fieldSz code1, fieldSz code2, fieldSz code3,
1188          fieldSz code4, fieldSz code5, fieldSz code6, fieldSz code7]
1189
1190    alignment itbl
1191       = (sum . map (\f -> f itbl))
1192         [fieldAl ptrs, fieldAl nptrs, fieldAl srtlen, fieldAl tipe,
1193          fieldAl code0, fieldAl code1, fieldAl code2, fieldAl code3,
1194          fieldAl code4, fieldAl code5, fieldAl code6, fieldAl code7]
1195
1196    poke a0 itbl
1197       = do a1 <- store (ptrs   itbl) (castPtr a0)
1198            a2 <- store (nptrs  itbl) a1
1199            a3 <- store (tipe   itbl) a2
1200            a4 <- store (srtlen itbl) a3
1201            a5 <- store (code0  itbl) a4
1202            a6 <- store (code1  itbl) a5
1203            a7 <- store (code2  itbl) a6
1204            a8 <- store (code3  itbl) a7
1205            a9 <- store (code4  itbl) a8
1206            aA <- store (code5  itbl) a9
1207            aB <- store (code6  itbl) aA
1208            aC <- store (code7  itbl) aB
1209            return ()
1210
1211    peek a0
1212       = do (a1,ptrs)   <- load (castPtr a0)
1213            (a2,nptrs)  <- load a1
1214            (a3,tipe)   <- load a2
1215            (a4,srtlen) <- load a3
1216            (a5,code0)  <- load a4
1217            (a6,code1)  <- load a5
1218            (a7,code2)  <- load a6
1219            (a8,code3)  <- load a7
1220            (a9,code4)  <- load a8
1221            (aA,code5)  <- load a9
1222            (aB,code6)  <- load aA
1223            (aC,code7)  <- load aB
1224            return StgInfoTable { ptrs = ptrs, nptrs = nptrs,
1225                                  srtlen = srtlen, tipe = tipe,
1226                                  code0 = code0, code1 = code1, code2 = code2,
1227                                  code3 = code3, code4 = code4, code5 = code5,
1228                                  code6 = code6, code7 = code7 }
1229
1230 fieldSz :: (Storable a, Storable b) => (a -> b) -> a -> Int
1231 fieldSz sel x = sizeOf (sel x)
1232
1233 fieldAl :: (Storable a, Storable b) => (a -> b) -> a -> Int
1234 fieldAl sel x = alignment (sel x)
1235
1236 store :: Storable a => a -> Ptr a -> IO (Ptr b)
1237 store x addr = do poke addr x
1238                   return (castPtr (addr `plusPtr` sizeOf x))
1239
1240 load :: Storable a => Ptr a -> IO (Ptr b, a)
1241 load addr = do x <- peek addr
1242                return (castPtr (addr `plusPtr` sizeOf x), x)
1243
1244 -----------------------------------------------------------------------------q
1245
1246 foreign import "strncpy" strncpy :: Ptr a -> ByteArray# -> CInt -> IO ()
1247 \end{code}
1248