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