ghc/compiler/stgSyn/StgInterp.lhs

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