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