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