compiler/ndpFlatten/Flattening.hs

   1 --  $Id$
   2 --
   3 --  Copyright (c) [2001..2002] Manuel M T Chakravarty & Gabriele Keller
   4 --
   5 --  Vectorisation and lifting
   6 --
   7 --- DESCRIPTION ---------------------------------------------------------------
   8 --
   9 --  This module implements the vectorisation and function lifting
  10 --  transformations of the flattening transformation.
  11 --
  12 --- DOCU ----------------------------------------------------------------------
  13 --
  14 --  Language: Haskell 98 with C preprocessor
  15 --
  16 --  Types:
  17 --    the transformation on types has five purposes:
  18 --
  19 --        1) for each type definition, derive the lifted version of this type
  20 --             liftTypeef
  21 --        2) change the type annotations of functions & variables acc. to rep.
  22 --             flattenType
  23 --        3) derive the type of a lifted function
  24 --             liftType
  25 --        4) sumtypes:
  26 --             this is the most fuzzy and complicated part. For each lifted
  27 --             sumtype we need to generate function to access and combine the
  28 --             component arrays
  29 --
  30 --   NOTE: the type information of variables and data constructors is *not*
  31 --          changed to reflect it's representation. This has to be solved
  32 --          somehow (???, FIXME)  using type indexed types
  33 --
  34 --   Vectorisation:
  35 --    is very naive at the moment. One of the most striking inefficiencies is
  36 --    application vect (app e1 e2) -> app (fst (vect e1) (vect e2)) if e1 is a
  37 --    lambda abstraction. The vectorisation produces a pair consisting of the
  38 --    original and the lifted function, but the lifted version is discarded.
  39 --    I'm also not sure how much of this would be thrown out by the simplifier
  40 --    eventually
  41 --
  42 --        *) vectorise
  43 --
  44 --  Conventions:
  45 --
  46 --- TODO ----------------------------------------------------------------------
  47 --
  48 --   * look closer into the definition of type definition (TypeThing or so)
  49 --
  50
  51 module Flattening (
  52   flatten, flattenExpr,
  53 ) where
  54
  55 #include "HsVersions.h"
  56
  57 -- friends
  58 import NDPCoreUtils (tupleTyArgs, funTyArgs, isDefault,
  59                      isLit, mkPArrTy, mkTuple, isSimpleExpr, substIdEnv)
  60 import FlattenMonad (Flatten, runFlatten, mkBind, extendContext, packContext,
  61                      liftVar, liftConst, intersectWithContext, mk'fst,
  62                      mk'mapP, mk'bpermuteDftP, mk'indexOfP,mk'eq,mk'neq)
  63
  64 -- GHC
  65 import TcType       ( tcIsForAllTy, tcView )
  66 import TypeRep      ( Type(..) )
  67 import Coercion     ( coercionKind )
  68 import StaticFlags  (opt_Flatten)
  69 import Panic        (panic)
  70 import ErrUtils     (dumpIfSet_dyn)
  71 import UniqSupply   (mkSplitUniqSupply)
  72 import DynFlags  (DynFlag(..))
  73 import Literal      (Literal, literalType)
  74 import Var          (Var(..), idType, isTyVar)
  75 import Id           (setIdType)
  76 import DataCon      (DataCon, dataConTag)
  77 import HscTypes     ( ModGuts(..), HscEnv(..), hscEPS )
  78 import CoreFVs      (exprFreeVars)
  79 import CoreSyn      (Expr(..), Bind(..), Alt, AltCon(..),
  80                      CoreBndr, CoreExpr, CoreBind, mkLams, mkLets,
  81                      mkApps, mkIntLitInt)
  82 import PprCore      (pprCoreExpr)
  83 import CoreLint     (showPass, endPass)
  84
  85 import CoreUtils    (exprType, applyTypeToArg, mkPiType)
  86 import VarEnv       (zipVarEnv)
  87 import TysWiredIn   (mkTupleTy)
  88 import BasicTypes   (Boxity(..))
  89 import Outputable
  90 import FastString
  91
  92 -- standard
  93 import Monad        (liftM, foldM)
  94
  95 -- toplevel transformation
  96 -- -----------------------
  97
  98 -- entry point to the flattening transformation for the compiler driver when
  99 -- compiling a complete module (EXPORTED)
 100 --
 101 flatten :: HscEnv
 102         -> ModGuts
 103         -> IO ModGuts
 104 flatten hsc_env mod_impl@(ModGuts {mg_binds = binds})
 105   | not opt_Flatten = return mod_impl -- skip without -fflatten
 106   | otherwise       =
 107   do
 108     let dflags = hsc_dflags hsc_env
 109
 110     eps <- hscEPS hsc_env
 111     us <- mkSplitUniqSupply 'l'         -- 'l' as in fLattening
 112     --
 113     -- announce vectorisation
 114     --
 115     showPass dflags "Flattening [first phase: vectorisation]"
 116     --
 117     -- vectorise all toplevel bindings
 118     --
 119     let binds' = runFlatten hsc_env eps us $ vectoriseTopLevelBinds binds
 120     --
 121     -- and dump the result if requested
 122     --
 123     endPass dflags "Flattening [first phase: vectorisation]"
 124             Opt_D_dump_vect binds'
 125     return $ mod_impl {mg_binds = binds'}
 126
 127 -- entry point to the flattening transformation for the compiler driver when
 128 -- compiling a single expression in interactive mode (EXPORTED)
 129 --
 130 flattenExpr :: HscEnv
 131             -> CoreExpr                 -- the expression to be flattened
 132             -> IO CoreExpr
 133 flattenExpr hsc_env expr
 134   | not opt_Flatten = return expr       -- skip without -fflatten
 135   | otherwise       =
 136   do
 137     let dflags = hsc_dflags hsc_env
 138     eps <- hscEPS hsc_env
 139
 140     us <- mkSplitUniqSupply 'l'         -- 'l' as in fLattening
 141     --
 142     -- announce vectorisation
 143     --
 144     showPass dflags "Flattening [first phase: vectorisation]"
 145     --
 146     -- vectorise the expression
 147     --
 148     let expr' = fst . runFlatten hsc_env eps us $ vectorise expr
 149     --
 150     -- and dump the result if requested
 151     --
 152     dumpIfSet_dyn dflags Opt_D_dump_vect "Vectorised expression"
 153                   (pprCoreExpr expr')
 154     return expr'
 155
 156
 157 -- vectorisation of bindings and expressions
 158 -- -----------------------------------------
 159
 160
 161 vectoriseTopLevelBinds:: [CoreBind] -> Flatten [CoreBind]
 162 vectoriseTopLevelBinds binds =
 163   do
 164     vbinds <- mapM vectoriseBind binds
 165     return (adjustTypeBinds vbinds)
 166
 167 adjustTypeBinds:: [CoreBind] -> [CoreBind]
 168 adjustTypeBinds vbinds =
 169     let
 170        ids = concat (map extIds vbinds)
 171        idEnv =  zipVarEnv ids ids
 172      in map (substIdEnvBind idEnv) vbinds
 173   where
 174     -- FIXME replace by 'bindersOf'
 175     extIds (NonRec b expr) = [b]
 176     extIds (Rec      bnds) = map fst bnds
 177     substIdEnvBind idEnv (NonRec b expr) = NonRec b (substIdEnv idEnv expr)
 178     substIdEnvBind idEnv (Rec bnds)
 179        = Rec (map (\ (b,e) -> (b, (substIdEnv idEnv e))) bnds)
 180
 181 -- vectorise a single core binder
 182 --
 183 vectoriseBind                 :: CoreBind -> Flatten CoreBind
 184 vectoriseBind (NonRec b expr)  =
 185   liftM (NonRec b) $ liftM fst $ vectorise expr
 186 vectoriseBind (Rec bindings)   =
 187   liftM Rec        $ mapM vectoriseOne bindings
 188   where
 189     vectoriseOne (b, expr) =
 190       do
 191         (vexpr, ty) <- vectorise expr
 192         return (setIdType b ty, vexpr)
 193
 194
 195 -- Searches for function definitions and creates a lifted version for
 196 -- each function.
 197 -- We have only two interesting cases:
 198 -- 1) function application  (ex1) (ex2)
 199 --      vectorise both subexpressions. The function will end up becoming a
 200 --      pair (orig. fun, lifted fun), choose first component (in many cases,
 201 --      this is pretty inefficient, since the lifted version is generated
 202 --      although it is clear that it won't be used
 203 --
 204 -- 2) lambda abstraction
 205 --      any function has to exist in two forms: it's original form and it's
 206 --      lifted form. Therefore, every lambda abstraction is transformed into
 207 --      a pair of functions: the original function and its lifted variant
 208 --
 209 --
 210 --  FIXME: currently, I use 'exprType' all over the place - this is terribly
 211 --  inefficient. It should be suffiecient to change 'vectorise' and 'lift' to
 212 --  return the type of the result expression as well.
 213 --
 214 vectorise:: CoreExpr -> Flatten (CoreExpr, Type)
 215 vectorise (Var id)  =
 216   do
 217     let varTy  = idType id
 218     let vecTy  = vectoriseTy varTy
 219     return (Var (setIdType id vecTy), vecTy)
 220
 221 vectorise (Lit lit) =
 222   return ((Lit lit), literalType lit)
 223
 224
 225 vectorise e@(App expr t@(Type _)) =
 226   do
 227     (vexpr, vexprTy) <- vectorise expr
 228     return ((App vexpr t), applyTypeToArg vexprTy t)
 229
 230 vectorise  (App (Lam b expr) arg) =
 231   do
 232     (varg, argTy)    <- vectorise arg
 233     (vexpr, vexprTy) <- vectorise expr
 234     let vb            = setIdType b argTy
 235     return ((App (Lam vb  vexpr) varg),
 236             applyTypeToArg (mkPiType vb vexprTy) varg)
 237
 238 -- if vexpr expects a type as first argument
 239 -- application stays just as it is
 240 --
 241 vectorise (App expr arg) =
 242   do
 243     (vexpr, vexprTy) <-  vectorise expr
 244     (varg,  vargTy)  <-  vectorise arg
 245
 246     if (tcIsForAllTy vexprTy)
 247       then do
 248         let resTy =  applyTypeToArg vexprTy varg
 249         return (App vexpr varg, resTy)
 250       else do
 251         let [t1, t2] = tupleTyArgs  vexprTy
 252         vexpr'      <-  mk'fst t1 t2 vexpr
 253         let resTy    = applyTypeToArg t1 varg
 254         return  ((App vexpr' varg), resTy)  -- apply the first component of
 255                                             -- the vectorized function
 256
 257 vectorise  e@(Lam b expr)
 258   | isTyVar b
 259   =  do
 260         (vexpr, vexprTy) <- vectorise expr          -- don't vectorise 'b'!
 261         return ((Lam b vexpr), mkPiType b vexprTy)
 262   | otherwise =
 263      do
 264        (vexpr, vexprTy)  <- vectorise expr
 265        let vb             = setIdType b (vectoriseTy (idType b))
 266        let ve             =  Lam  vb  vexpr
 267        (lexpr, lexprTy)  <- lift e
 268        let veTy = mkPiType vb vexprTy
 269        return $ (mkTuple [veTy, lexprTy] [ve, lexpr],
 270                  mkTupleTy Boxed 2 [veTy, lexprTy])
 271
 272 vectorise (Let bind body) =
 273   do
 274     vbind            <- vectoriseBind bind
 275     (vbody, vbodyTy) <- vectorise body
 276     return ((Let vbind vbody), vbodyTy)
 277
 278 vectorise (Case expr b ty alts) =
 279   do
 280     (vexpr, vexprTy) <- vectorise expr
 281     valts <- mapM vectorise' alts
 282     let res_ty = snd (head valts)
 283     return (Case vexpr (setIdType b vexprTy) res_ty (map fst valts), res_ty)
 284   where vectorise' (con, bs, expr) =
 285           do
 286             (vexpr, vexprTy) <- vectorise expr
 287             return ((con, bs, vexpr), vexprTy)  -- FIXME: change type of con
 288                                                 --   and bs
 289
 290
 291
 292 vectorise (Note note expr) =
 293  do
 294    (vexpr, vexprTy) <- vectorise expr        -- FIXME: is this ok or does it
 295    return ((Note note vexpr), vexprTy)       --   change the validity of note?
 296
 297 vectorise e@(Type t) =
 298   return (e, t)                              -- FIXME: panic instead of 't'???
 299
 300
 301 {-
 302 myShowTy (TyVarTy _) = "TyVar "
 303 myShowTy (AppTy t1 t2) =
 304   "AppTy (" ++ (myShowTy t1) ++ ", " ++ (myShowTy t2) ++ ")"
 305 myShowTy (TyConApp _ t) =
 306   "TyConApp TC (" ++ (myShowTy t) ++ ")"
 307 -}
 308
 309 vectoriseTy :: Type -> Type
 310 vectoriseTy ty | Just ty' <- tcView ty = vectoriseTy ty'
 311         -- Look through notes and synonyms
 312         -- NB: This will discard notes and synonyms, of course
 313         -- ToDo: retain somehow?
 314 vectoriseTy t@(TyVarTy v)      =  t
 315 vectoriseTy t@(AppTy t1 t2)    =
 316   AppTy (vectoriseTy t1) (vectoriseTy t2)
 317 vectoriseTy t@(TyConApp tc ts) =
 318   TyConApp tc (map vectoriseTy ts)
 319 vectoriseTy t@(FunTy t1 t2)    =
 320   mkTupleTy Boxed 2 [(FunTy (vectoriseTy t1) (vectoriseTy t2)),
 321                      (liftTy t)]
 322 vectoriseTy  t@(ForAllTy v ty)  =
 323   ForAllTy v (vectoriseTy  ty)
 324 vectoriseTy  t =  t
 325
 326
 327 -- liftTy: wrap the type in an array but be careful with function types
 328 --    on the *top level* (is this sufficient???)
 329
 330 liftTy:: Type -> Type
 331 liftTy ty | Just ty' <- tcView ty = liftTy ty'
 332 liftTy (FunTy t1 t2)   = FunTy (liftTy t1) (liftTy t2)
 333 liftTy (ForAllTy tv t) = ForAllTy tv (liftTy t)
 334 liftTy  t              = mkPArrTy t
 335
 336
 337 --  lifting:
 338 -- ----------
 339 --  * liftType
 340 --  * lift
 341
 342
 343 -- liftBinderType: Converts a  type 'a' stored in the binder to the
 344 -- representation of '[:a:]' will therefore call liftType
 345 --
 346 --  lift type, don't change name (incl unique) nor IdInfo. IdInfo looks ok,
 347 --  but I'm not entirely sure about some fields (e.g., strictness info)
 348 liftBinderType:: CoreBndr ->  Flatten CoreBndr
 349 liftBinderType bndr = return $  setIdType bndr (liftTy (idType bndr))
 350
 351 -- lift: lifts an expression (a -> [:a:])
 352 -- If the expression is a simple expression, it is treated like a constant
 353 -- expression.
 354 -- If the body of a lambda expression is a simple expression, it is
 355 -- transformed into a mapP
 356 lift:: CoreExpr -> Flatten (CoreExpr, Type)
 357 lift cExpr@(Var id)    =
 358   do
 359     lVar@(Var lId) <- liftVar id
 360     return (lVar, idType lId)
 361
 362 lift cExpr@(Lit lit)   =
 363   do
 364     lLit  <- liftConst cExpr
 365     return (lLit, exprType lLit)
 366
 367
 368 lift (Lam b expr)
 369   | isSimpleExpr expr      =  liftSimpleFun b expr
 370   | isTyVar b =
 371     do
 372       (lexpr, lexprTy) <- lift expr  -- don't lift b!
 373       return (Lam b lexpr, mkPiType b lexprTy)
 374   | otherwise =
 375     do
 376       lb               <- liftBinderType b
 377       (lexpr, lexprTy) <- extendContext [lb] (lift expr)
 378       return ((Lam lb lexpr) , mkPiType lb lexprTy)
 379
 380 lift (App expr1 expr2) =
 381   do
 382     (lexpr1, lexpr1Ty) <- lift expr1
 383     (lexpr2, _)        <- lift expr2
 384     return ((App lexpr1 lexpr2), applyTypeToArg lexpr1Ty lexpr2)
 385
 386
 387 lift (Let (NonRec b expr1) expr2)
 388   |isSimpleExpr expr2 =
 389     do
 390       (lexpr1, _)        <- lift expr1
 391       (lexpr2, lexpr2Ty) <- liftSimpleFun b expr2
 392       let (t1, t2) = funTyArgs lexpr2Ty
 393       liftM (\x -> (x, liftTy t2)) $  mk'mapP t1 t2 lexpr2 lexpr1
 394
 395   | otherwise =
 396     do
 397       (lexpr1, _)        <- lift expr1
 398       lb                 <- liftBinderType b
 399       (lexpr2, lexpr2Ty) <- extendContext [lb] (lift expr1)
 400       return ((Let (NonRec lb lexpr1) lexpr2), lexpr2Ty)
 401
 402 lift (Let (Rec binds) expr2) =
 403   do
 404     let (bndVars, exprs)  = unzip binds
 405     lBndVars           <- mapM liftBinderType bndVars
 406     lexprs             <- extendContext bndVars (mapM lift exprs)
 407     (lexpr2, lexpr2Ty) <- extendContext bndVars (lift expr2)
 408     return ((Let (Rec (zip  lBndVars (map fst lexprs))) lexpr2), lexpr2Ty)
 409
 410 -- FIXME:
 411 -- Assumption: alternatives can either be literals or data construtors.
 412 --             Due to type restrictions, I don't think it is possible
 413 --             that they are mixed.
 414 --             The handling of literals and data constructors is completely
 415 --             different
 416 --
 417 --
 418 -- let b = expr in alts
 419 --
 420 -- I think I read somewhere that the default case (if present) is stored
 421 -- in the head of the list. Assume for now this is true, have to check
 422 --
 423 -- (1) literals
 424 -- (2) data constructors
 425 --
 426 -- FIXME: optimisation: first, filter out all simple expression and
 427 --   loop (mapP & filter) over all the corresponding values in a single
 428 --   traversal:
 429
 430 --    (1) splitAlts:: [Alt CoreBndr] -> ([Alt CoreBndr],[Alt CoreBndr])
 431 --                                       simple alts     reg alts
 432 --    (2) if simpleAlts = [] then (just as before)
 433 --        if regAlts    = [] then (the whole thing is just a loop)
 434 --        otherwise (a) compute index vector for simpleAlts (for def permute
 435 --                      later on
 436 --                  (b)
 437 -- gaw 2004 FIX?
 438 lift cExpr@(Case expr b _ alts)  =
 439   do
 440     (lExpr, _) <- lift expr
 441     lb    <- liftBinderType  b     -- lift alt-expression
 442     lalts <- if isLit alts
 443                 then extendContext [lb] (liftCaseLit b alts)
 444                 else extendContext [lb] (liftCaseDataCon b alts)
 445     letWrapper lExpr b lalts
 446
 447 lift (Cast expr co) =
 448   do
 449     (lexpr, t) <- lift expr
 450     let lco = liftTy co
 451     let (t1, t2) = coercionKind lco
 452     return ((Cast expr lco), t2)
 453
 454 lift (Note note expr) =
 455   do
 456     (lexpr, t) <- lift expr
 457     return ((Note note lexpr), t)
 458
 459 lift e@(Type t) = return (e, t)
 460
 461
 462 -- auxilliary functions for lifting of case statements
 463 --
 464
 465 liftCaseDataCon:: CoreBndr -> [Alt CoreBndr] ->
 466        Flatten (([CoreBind], [CoreBind], [CoreBind]))
 467 liftCaseDataCon b [] =
 468   return ([], [], [])
 469 liftCaseDataCon b alls@(alt:alts)
 470   | isDefault alt  =
 471     do
 472       (i,  e,  defAltBndrs) <- liftCaseDataConDefault b alt alts
 473       (is, es, altBndrs)    <- liftCaseDataCon' b alts
 474       return (i:is, e:es, defAltBndrs ++ altBndrs)
 475   | otherwise =
 476     liftCaseDataCon' b alls
 477
 478 liftCaseDataCon':: CoreBndr -> [Alt CoreBndr] ->
 479     Flatten ([CoreBind], [CoreBind], [CoreBind])
 480 liftCaseDataCon' _ [] =
 481   do
 482     return ([], [], [])
 483
 484
 485 liftCaseDataCon' b ((DataAlt dcon, bnds, expr): alts) =
 486   do
 487     (permBnd, exprBnd, packBnd)    <-  liftSingleDataCon b dcon bnds expr
 488     (permBnds, exprBnds, packBnds) <-  liftCaseDataCon' b alts
 489     return (permBnd:permBnds, exprBnd:exprBnds, packBnd ++ packBnds)
 490
 491
 492 -- FIXME: is is really necessary to return the binding to the permutation
 493 -- array in the data constructor case, as the representation already
 494 -- contains the extended flag vector
 495 liftSingleDataCon:: CoreBndr -> DataCon -> [CoreBndr] -> CoreExpr ->
 496   Flatten (CoreBind, CoreBind, [CoreBind])
 497 liftSingleDataCon b dcon bnds expr =
 498   do
 499     let dconId           = dataConTag dcon
 500     indexExpr           <- mkIndexOfExprDCon (idType b)  b dconId
 501     (bb, bbind)         <- mkBind FSLIT("is") indexExpr
 502     lbnds               <- mapM liftBinderType bnds
 503     ((lExpr, _), bnds') <- packContext  bb (extendContext lbnds (lift expr))
 504     (_, vbind)          <- mkBind FSLIT("r") lExpr
 505     return (bbind, vbind, bnds')
 506
 507 -- FIXME: clean this up. the datacon and the literal case are so
 508 --   similar that it would be easy to use the same function here
 509 --   instead of duplicating all the code.
 510 --
 511 liftCaseDataConDefault:: CoreBndr -> (Alt CoreBndr) ->  [Alt CoreBndr]
 512   ->  Flatten (CoreBind, CoreBind, [CoreBind])
 513 liftCaseDataConDefault b (_, _, def) alts =
 514   do
 515     let dconIds        = map (\(DataAlt d, _, _) -> dataConTag d) alts
 516     indexExpr         <- mkIndexOfExprDConDft (idType b) b dconIds
 517     (bb, bbind)       <- mkBind FSLIT("is") indexExpr
 518     ((lDef, _), bnds) <- packContext  bb (lift def)
 519     (_, vbind)        <- mkBind FSLIT("r") lDef
 520     return (bbind, vbind, bnds)
 521
 522 -- liftCaseLit: checks if we have a default case and handles it
 523 -- if necessary
 524 liftCaseLit:: CoreBndr -> [Alt CoreBndr] ->
 525        Flatten ([CoreBind], [CoreBind], [CoreBind])
 526 liftCaseLit b [] =
 527     return ([], [], [])    --FIXME: a case with no cases at all???
 528 liftCaseLit b alls@(alt:alts)
 529   | isDefault alt  =
 530     do
 531         (i,  e,  defAltBndrs) <- liftCaseLitDefault b alt alts
 532         (is, es, altBndrs)    <- liftCaseLit' b alts
 533         return (i:is, e:es, defAltBndrs ++ altBndrs)
 534   | otherwise =
 535     do
 536       liftCaseLit' b alls
 537
 538 -- liftCaseLitDefault: looks at all the other alternatives which
 539 --    contain a literal and filters all those elements from the
 540 --    array which do not match any of the literals in the other
 541 --    alternatives.
 542 liftCaseLitDefault:: CoreBndr -> (Alt CoreBndr) ->  [Alt CoreBndr]
 543   ->  Flatten (CoreBind, CoreBind, [CoreBind])
 544 liftCaseLitDefault b (_, _, def) alts =
 545   do
 546     let lits           = map (\(LitAlt l, _, _) -> l) alts
 547     indexExpr         <- mkIndexOfExprDft (idType b) b lits
 548     (bb, bbind)       <- mkBind FSLIT("is") indexExpr
 549     ((lDef, _), bnds) <- packContext  bb (lift def)
 550     (_, vbind)        <- mkBind FSLIT("r") lDef
 551     return (bbind, vbind, bnds)
 552
 553 -- FIXME:
 554 --  Assumption: in case of Lit, the list of binders of the alt is empty.
 555 --
 556 -- returns
 557 --   a list of all vars bound to the expr in the body of the alternative
 558 --   a list of (var, expr) pairs, where var has to be bound to expr
 559 --   by letWrapper
 560 liftCaseLit':: CoreBndr -> [Alt CoreBndr] ->
 561     Flatten ([CoreBind], [CoreBind], [CoreBind])
 562 liftCaseLit' _ [] =
 563   do
 564     return ([], [], [])
 565 liftCaseLit' b ((LitAlt lit, [], expr):alts) =
 566   do
 567     (permBnd, exprBnd, packBnd)    <-  liftSingleCaseLit b lit expr
 568     (permBnds, exprBnds, packBnds) <-  liftCaseLit' b alts
 569     return (permBnd:permBnds, exprBnd:exprBnds, packBnd ++ packBnds)
 570
 571 -- lift a single alternative of the form: case  b of lit -> expr.
 572 --
 573 --   It returns the bindings:
 574 --   (a) let b' = indexOfP (mapP (\x -> x == lit) b)
 575 --
 576 --   (b) lift expr in the packed context. Returns lexpr and the
 577 --       list of binds (bnds) that describe the packed arrays
 578 --
 579 --   (c) create new var v' to bind lexpr to
 580 --
 581 --   (d) return (b' = indexOf...., v' = lexpr, bnds)
 582 liftSingleCaseLit:: CoreBndr -> Literal -> CoreExpr  ->
 583   Flatten (CoreBind, CoreBind, [CoreBind])
 584 liftSingleCaseLit b lit expr =
 585  do
 586    indexExpr          <- mkIndexOfExpr (idType b) b lit -- (a)
 587    (bb, bbind)        <- mkBind FSLIT("is") indexExpr
 588    ((lExpr, t), bnds) <- packContext  bb (lift expr)     -- (b)
 589    (_, vbind)         <- mkBind FSLIT("r") lExpr
 590    return (bbind, vbind, bnds)
 591
 592 -- letWrapper lExpr b ([indexbnd_i], [exprbnd_i], [pckbnd_ij])
 593 --
 594 -- let b = lExpr in
 595 --  let index_bnd_1 in
 596 --    let packbnd_11 in
 597 --      ... packbnd_1m in
 598 --         let exprbnd_1 in        ....
 599 --      ...
 600 --          let nvar = replicate dummy (length <current context>)
 601 --               nvar1 = bpermuteDftP index_bnd_1 ...
 602 --
 603 --   in bpermuteDftP index_bnd_n nvar_(n-1)
 604 --
 605 letWrapper:: CoreExpr -> CoreBndr ->([CoreBind], [CoreBind], [CoreBind]) ->
 606   Flatten (CoreExpr, Type)
 607 letWrapper lExpr b (indBnds, exprBnds, pckBnds)  =
 608   do
 609     (defBpBnds, ty) <- dftbpBinders indBnds exprBnds
 610     let resExpr      = getExprOfBind (head defBpBnds)
 611     return ((mkLets (indBnds ++ pckBnds ++ exprBnds ++ defBpBnds) resExpr), ty)
 612
 613 -- dftbpBinders: return the list of binders necessary to construct the overall
 614 --   result from the subresults computed in the different branches of the case
 615 --   statement. The binding which contains the final result is in the *head*
 616 --   of the result list.
 617 --
 618 -- dftbpBinders [ind_i = ...] [expr_i = ...] = [dn = ..., d_n-1 = .., d1 = ...]
 619 --
 620 -- let def = replicate (length of context) undefined
 621 --     d1  = bpermuteDftP dft e1 i1
 622 --     .....
 623 --
 624 dftbpBinders:: [CoreBind] -> [CoreBind] -> Flatten ([CoreBind], Type)
 625 dftbpBinders indexBnds exprBnds =
 626   do
 627     let expr = getExprOfBind (head exprBnds)
 628     defVecExpr     <- createDftArrayBind expr
 629     ((b, bnds), t) <- dftbpBinders' indexBnds exprBnds defVecExpr
 630     return ((b:bnds),t)
 631   where
 632     dftbpBinders' :: [CoreBind]
 633                   -> [CoreBind]
 634                   -> CoreBind
 635                   -> Flatten ((CoreBind, [CoreBind]), Type)
 636     dftbpBinders' [] [] cBnd =
 637       return ((cBnd, []), panic "dftbpBinders: undefined type")
 638     dftbpBinders' (i:is) (e:es) cBind =
 639       do
 640         let iVar = getVarOfBind i
 641         let eVar = getVarOfBind e
 642         let cVar = getVarOfBind cBind
 643         let ty   = idType eVar
 644         newBnd  <- mkDftBackpermute ty iVar eVar cVar
 645         ((fBnd, restBnds), _) <- dftbpBinders' is es newBnd
 646         return ((fBnd, (newBnd:restBnds)), liftTy ty)
 647
 648     dftbpBinders'  _ _ _ =
 649       panic "Flattening.dftbpBinders: index and expression binder lists have different length!"
 650
 651 getExprOfBind:: CoreBind -> CoreExpr
 652 getExprOfBind (NonRec _ expr) = expr
 653
 654 getVarOfBind:: CoreBind -> Var
 655 getVarOfBind (NonRec b _) = b
 656
 657
 658
 659 -- Optimised Transformation
 660 -- =========================
 661 --
 662
 663 -- liftSimpleFun
 664 --   if variables x_1 to x_i occur in the context *and* free in expr
 665 --   then
 666 --   (liftSimpleExpression expr) => mapP (\ (x1,..xn) -> expr) (x1,..xn)
 667 --
 668 liftSimpleFun:: CoreBndr -> CoreExpr -> Flatten (CoreExpr, Type)
 669 liftSimpleFun b expr =
 670   do
 671     bndVars <- collectBoundVars expr
 672     let bndVars'     = b:bndVars
 673         bndVarsTuple = mkTuple (map idType bndVars') (map Var bndVars')
 674         lamExpr      = mkLams (b:bndVars) expr     -- FIXME: should be tuple
 675                                                    -- here
 676     let (t1, t2)     = funTyArgs . exprType $ lamExpr
 677     mapExpr         <-  mk'mapP t1 t2 lamExpr bndVarsTuple
 678     let lexpr        = mkApps mapExpr [bndVarsTuple]
 679     return (lexpr, undefined)                      -- FIXME!!!!!
 680
 681
 682 collectBoundVars:: CoreExpr -> Flatten [CoreBndr]
 683 collectBoundVars  expr =
 684   intersectWithContext (exprFreeVars expr)
 685
 686
 687 -- auxilliary routines
 688 -- -------------------
 689
 690 -- mkIndexOfExpr b lit ->
 691 --   indexOf (mapP (\x -> x == lit) b) b
 692 --
 693 mkIndexOfExpr:: Type -> CoreBndr -> Literal -> Flatten CoreExpr
 694 mkIndexOfExpr  idType b lit =
 695   do
 696     eqExpr        <- mk'eq idType (Var b) (Lit lit)
 697     let lambdaExpr = (Lam b eqExpr)
 698     mk'indexOfP idType  lambdaExpr (Var b)
 699
 700 -- there is FlattenMonad.mk'indexOfP as well as
 701 -- CoreSyn.mkApps and CoreSyn.mkLam, all of which should help here
 702
 703 -- for case-distinction over data constructors:
 704 -- let b = expr in
 705 --   case b of
 706 --      dcon args -> ....
 707 -- dconId = dataConTag dcon
 708 -- the call "mkIndexOfExprDCon b dconId" computes the core expression for
 709 -- indexOfP (\x -> x == dconId) b)
 710 --
 711 mkIndexOfExprDCon::Type -> CoreBndr -> Int -> Flatten CoreExpr
 712 mkIndexOfExprDCon  idType b dId =
 713   do
 714     let intExpr    = mkIntLitInt dId
 715     eqExpr        <- mk'eq  idType (Var b) intExpr
 716     let lambdaExpr = (Lam b intExpr)
 717     mk'indexOfP idType lambdaExpr (Var b)
 718
 719
 720
 721 -- there is FlattenMonad.mk'indexOfP as well as
 722 -- CoreSyn.mkApps and CoreSyn.mkLam, all of which should help here
 723
 724 -- mk'IndexOfExprDConDft b dconIds : Generates the index expression for the
 725 -- default case. "dconIds" is a list of all the data constructor idents which
 726 -- are covered by the other cases.
 727 -- indexOfP (\x -> x != dconId_1 && ....) b)
 728 --
 729 mkIndexOfExprDConDft:: Type -> CoreBndr -> [Int] -> Flatten CoreExpr
 730 mkIndexOfExprDConDft idType b dId  =
 731   do
 732     let intExprs   = map mkIntLitInt dId
 733     bExpr         <- foldM (mk'neq idType) (head intExprs) (tail intExprs)
 734     let lambdaExpr = (Lam b bExpr)
 735     mk'indexOfP idType (Var b) bExpr
 736
 737
 738 -- mkIndexOfExprDef b [lit1, lit2,...] ->
 739 --   indexOf (\x -> not (x == lit1 || x == lit2 ....) b
 740 mkIndexOfExprDft:: Type -> CoreBndr -> [Literal] -> Flatten CoreExpr
 741 mkIndexOfExprDft idType b lits =
 742   do
 743     let litExprs   = map (\l-> Lit l)  lits
 744     bExpr         <- foldM (mk'neq idType) (head litExprs) (tail litExprs)
 745     let lambdaExpr = (Lam b bExpr)
 746     mk'indexOfP idType bExpr (Var b)
 747
 748
 749 -- create a back-permute binder
 750 --
 751 --  * `mkDftBackpermute ty indexArrayVar srcArrayVar dftArrayVar' creates a
 752 --   Core binding of the form
 753 --
 754 --     x = bpermuteDftP indexArrayVar srcArrayVar dftArrayVar
 755 --
 756 --   where `x' is a new local variable
 757 --
 758 mkDftBackpermute :: Type -> Var -> Var -> Var -> Flatten CoreBind
 759 mkDftBackpermute ty idx src dft =
 760   do
 761     rhs <- mk'bpermuteDftP ty (Var idx) (Var src) (Var dft)
 762     liftM snd $ mkBind FSLIT("dbp") rhs
 763
 764 -- create a dummy array with elements of the given type, which can be used as
 765 -- default array for the combination of the subresults of the lifted case
 766 -- expression
 767 --
 768 createDftArrayBind    :: CoreExpr -> Flatten CoreBind
 769 createDftArrayBind e  =
 770   panic "Flattening.createDftArrayBind: not implemented yet"
 771 {-
 772   do
 773     let ty = parrElemTy . exprType $ expr
 774     len <- mk'lengthP e
 775     rhs <- mk'replicateP ty len err??
 776     lift snd $ mkBind FSLIT("dft") rhs
 777 FIXME: nicht so einfach; man kann kein "error"-Wert nehmen, denn der w"urde
 778   beim bpermuteDftP sofort evaluiert, aber es ist auch schwer m"oglich einen
 779   generischen Wert f"ur jeden beliebigen Typ zu erfinden.
 780 -}
 781
 782
 783
 784
 785 -- show functions (the pretty print functions sometimes don't
 786 -- show it the way I want....
 787
 788 -- shows just the structure
 789 showCoreExpr (Var _ )    = "Var "
 790 showCoreExpr (Lit _) = "Lit "
 791 showCoreExpr (App e1 e2) =
 792   "(App \n  " ++ (showCoreExpr e1) ++ "\n  " ++ (showCoreExpr e2) ++ ") "
 793 showCoreExpr (Lam b e)   =
 794   "Lam b " ++ (showCoreExpr e)
 795 showCoreExpr (Let bnds expr) =
 796   "Let \n" ++ (showBinds bnds) ++ "in " ++ (showCoreExpr expr)
 797   where showBinds (NonRec b e) = showBind (b,e)
 798         showBinds (Rec bnds)   = concat (map showBind bnds)
 799         showBind (b,e) = "  b = " ++ (showCoreExpr e)++ "\n"
 800 -- gaw 2004 FIX?
 801 showCoreExpr (Case ex b ty alts) =
 802   "Case b = " ++ (showCoreExpr ex) ++ " of \n" ++ (showAlts alts)
 803   where showAlts _ = ""
 804 showCoreExpr (Note _ ex) = "Note n " ++ (showCoreExpr ex)
 805 showCoreExpr (Type t) = "Type"