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