ghc/compiler/ghci/StgInterp.lhs

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