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