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