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