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