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