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