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