content: -- Package of utility functions used by iConvLet in IConv
  module IConvLet(
                  docycles, reorderDs, unpoly
              ) where
  
  import qualified Data.List as List
  
  import Util(mapSnd)
  import FStringCompat(concatFString)
  import PPrint(ppReadable)
  --import PPring(ppString)
  import Error(internalError, ErrMsg(..), ErrorHandle, bsErrorUnsafe)
  import Position
  import CSyntax
  import CSyntaxUtil(mkPairType)
  import Id
  import PreStrings(fsDollar)
  import PreIds(idPrimFst, idPrimSnd, idPrimPair)
  -- import Debug.Trace
  
  
  docycles :: ErrorHandle -> [CDefl] -> [[Id]] -> [CDefl]
  docycles errh ds cycles =
      -- trace("docycles = " ++ (ppReadable cycles)) $
      concatMap (do_one_cyclegroup errh ds) cycles
  
  do_one_cyclegroup :: ErrorHandle -> [CDefl] -> [Id] -> [CDefl]
  do_one_cyclegroup errh original_ds is =
              let
                  ds' = reorderDs original_ds is
                        -- we use reorderDs just as a lookup function;
                        -- we actually do not care too much what order
                        -- they come out
  
              in case ds' of
                   [] -> internalError ("iConvLet: empty cycle")
                   [_] -> internalError ("iConvLet: cycle of one element")
                   _ -> many_cycle errh ds'
  
  type Pick_func = CExpr -> CExpr
  
  -- examples of  "Pick_func" are fst, fst.snd, fst.snd.snd, ...
  
  
  pick_func_list :: [CType] -> (CType,[Pick_func])
  -- For a given size (defined by the length of the CType list),
  -- this function returns a list of functions each of which "picks" the
  -- Nth element out of a large tuple created out of primPairs.
  -- For example, for size three, the list of functions returned
  -- is [fst, fst.snd, snd.snd] where "." is the compose operator.
  
  pick_func_list [] = internalError "pick_func_list : empty list"
  pick_func_list [_] = internalError "pick_func_list : singleton"
  pick_func_list [ft1,ft2] = (mkPairType ft1 ft2,
                              [(\x -> CApply (the_pick idPrimFst) [x]),
                               (\y -> CApply (the_pick idPrimSnd) [y])])
      where
            the_pick :: Id -> CExpr
            the_pick x = (CTApply (CSelectT idPrimPair x) [ft1, ft2])
  
  pick_func_list (a:rest) = let (t_rest, p_rest) = pick_func_list rest
                                the_pick :: Id -> CExpr
                                the_pick x = CTApply (CSelectT idPrimPair x) [a,t_rest]
                                apply_the_pick :: Pick_func -> Pick_func
                                apply_the_pick f = let
                                    g x = f (CApply (the_pick idPrimSnd) [x])
                                          in g
                                             -- ((CApply (the_pick idPrimSnd)) . )
                                first x = CApply (the_pick idPrimFst) [x]
                            in
                               (mkPairType a t_rest,
                                first:
                                (map apply_the_pick  p_rest))
  
  -- turns a list of expressions into a tuple expression
  typed_pair_expr :: [(CExpr,CType)] -> CExpr
  typed_pair_expr [] = internalError "typed_pair_expr : empty list"
  typed_pair_expr [_] = internalError "typed_pair_expr : singleton"
  typed_pair_expr [(e1, ft1), (e2, ft2)] = CStructT (mkPairType ft1 ft2)
                                            [(idPrimFst, e1), (idPrimSnd, e2)]
  typed_pair_expr ((e,ty):rest) =
      let rest_e = typed_pair_expr rest
      in case rest_e of
           (CStructT rest_t _) -> CStructT (mkPairType ty rest_t)
                                  [(idPrimFst, e), (idPrimSnd, rest_e)]
           _ -> internalError "typed_pair_expr . rest_e"
  
  many_cycle :: ErrorHandle -> [CDefl] -> [CDefl]
  {-
   Given a list of mutual recursive definitions: E.g.,
   let a = definition of "a" which calls ... b ...
       b = definition of "b" which calls ... c ...
       c = definition of "c" which calls ... a ...
  
  return a definition such that it is a singly recursive tuple,
  and everything else "indexes" into the tuple.
  
   let a$b$c = ...
       a     = first a$b$c
       b     = second a$b$c
       c     = third a$b$c
  
  The "first", "second", "third", etc., are the pick_func_list.
  
  Then, deal_with_cycles above feeds these singly recursive things
  back into iConvLet which applies primFix to them.
  
  a$b$c is defined
  
  let a$b$c = let a     = first a$b$c
                  b     = second a$b$c
                  c     = third a$b$c
              in ( definition of "a" ... b ...
                 , definition of "b" ... c ...
                 , definition of "c" ... a ...
                 )
  
  where the "a", "b", and "c" mask the "outer" definitions of them and
  allow the original expressions that defined "a" "b" and "c" to be used
  unchanged.  Somewhat miraculously, this construction (variables, e.g.,
  "a", bound inside a "let" referring to the function within which it
  defined, e.g., "a$b$c") does not count as mutual recursion.
  
  -}
  
  many_cycle errh ds@(d1:_) =
  {-    trace ("many_cycle:\n" ++ (ppReadable ds)
             ++ "\n"
             ++ (ppReadable answer)
             ++ "----------- /many_cycle") $ -}
      answer:pick_defs
      where answer :: CDefl
            answer = CLValueSign def quals
            def :: CDef
            def = CDefT def_id def_tvars def_qtype def_clauses
                where
                  def_tvars :: [TyVar]
                  -- Might need to do renaming of type variables? XXX
                  -- For now, if anything goes horribly wrong, we are going to
                  -- rely on ISyntaxCheck to error out.
                  def_tvars = -- trace_answer (\x -> "tvars " ++ (ppReadable x)) $
                              concatMap get_tvars ds -- ??
                  def_qtype :: CQType
                  -- Dropping the type contexts (they should be dealt with now).
                  -- Might break for local mutual recursion that's polymorphic
                  -- (because takes as arguments dictionaries that fails the
                  -- later check: EMutualRecursionComplicatedClause)
                  -- See testcase "Letrect.bs"
                  def_qtype = CQType [] (fst picks)
                  def_clauses :: [CClause]
                  def_clauses = [CClause [] [] def_expr]
                  def_expr :: CExpr
                  -- these "inner" pick_defs shadow the "outer" ones and are used
                  -- by the tuple itself.  In this way we avoid mutual recursion.
                  def_expr = Cletrec pick_defs inner_expr
                  inner_expr :: CExpr
                  inner_expr = typed_pair_expr (zip (map get_expression ds)
                                                    types)
            quals :: [CQual]
            quals = concatMap get_quals ds
  
            get_type :: CDefl -> CType
            get_type (CLValueSign (CDefT _ _ (CQType _ t) _ ) _ ) = t
            get_type _ = internalError ("many_cycle . get_type")
            get_id :: CDefl -> Id
            get_id (CLValueSign (CDefT i _ _ _ ) _ ) = i
            get_id _ = internalError ("many_cycle . id")
            get_tvars :: CDefl -> [TyVar]
            get_tvars (CLValueSign (CDefT _ vs _ _) _) = vs
            get_tvars _ = internalError "many_cycle . get_tvars"
            get_expression :: CDefl -> CExpr
            get_expression d@(CLValueSign (CDefT _ _ _ clauses) _) =
                case clauses of
                  [(CClause [] [] e)] -> e
                  _ -> bsErrorUnsafe errh
                       [(getPosition d,
                         EMutualRecursionComplicatedClause (ppReadable (get_id d)))]
                       -- Desugaring makes this error case happen less frequently
                       -- than expected.  For example:
      {-
  five :: Integer
  five = let evens :: Integer -> List Integer
             evens x = cons x (map ((+) 1) odds)
             odds  :: List Integer = map ((+) 1) (evens 101)
         in odds !! 3
  -}
    -- will compile just fine, because (evens x) gets desugared into
    -- evens = let _tctemp x = ... in _tctemp
  
            get_expression _ = internalError "many_cycle . get_expression"
            get_quals :: CDefl -> [CQual]
            get_quals (CLValueSign _ me) = me
            get_quals _ = internalError "many_cycle . get_quals"
            types :: [CType]
            types = map get_type ds
  
            picks :: (CType,[Pick_func])
            picks = pick_func_list types
  
            -- these defs are used twice, once inside the tuple ("inner" referred to
            -- above, and the outer ones that live in the same scope as the original
            -- definitions.  They have the same names as the original definitions.
            pick_defs :: [CDefl]
            pick_defs = zipWith create_def ds (snd picks)
  
            create_def :: CDefl -> Pick_func -> CDefl
            create_def (CLValueSign (CDefT i vs qt _) quals) pick =
                -- trace ("create_def quals " ++ (ppReadable quals)) $
                CLValueSign (CDefT i vs qt [CClause [] -- arguments (including patterns)
                                            [] -- qualifiers ??
                    -- empty values for "arguments" and "qualifiers" are OK because of
                    -- the filter in get_expression
                                            (pick (CVar def_id))])
                                quals -- qualifiers??
            create_def _ _ = internalError("many_cycle . create_def")
  
            def_id :: Id
            -- this has a chance of causing name collisions.
            def_id = mkId pos1 $ concatFString
                     (List.intersperse fsDollar (map (getIdBase . get_id) ds))
  
            pos1 :: Position
            pos1 = getPosition d1 -- arbitrarily picking a reasonable position
  
  many_cycle _ _ = internalError "many_cycle on empty list"
  
  
  
  -- Prevent polymorphic recursion in self-recursive bindings.
  -- Not clear why.
  unpoly :: Id -> CExpr -> CExpr
  unpoly i (CLam _ _) = internalError "IConv.unpoly: CLam"
  unpoly i (CLamT _ _ _) = internalError "IConv.unpoly: CLamT"
  unpoly i (Cletrec ds e) = Cletrec (map (unpolyd i) ds) (unpoly i e)
  unpoly i (Cletseq ds e) = Cletseq (map (unpolyd i) ds) (unpoly i e)
  unpoly i (CSelect _ _) = internalError "IConv.unpoly: CSelect"
  unpoly i (CCon _ _) = internalError "IConv.unpoly: CCon"
  unpoly i (Ccase _ _ _) = internalError "IConv.unpoly: Ccase"
  unpoly i (CStruct _ _ _) = internalError "IConv.unpoly: CStruct"
  unpoly i (CStructUpd _ _) = internalError "IConv.unpoly: CStructUpd"
  unpoly i (Cwrite _ _ _) = internalError "IConv.unpoly: Cwrite"
  unpoly i e@(CAny {}) = e
  unpoly i e@(CVar _) = e
  -- this is the interesting case
  unpoly i (CApply (CTApply f@(CVar i') _) es) | i == i' = CApply f (map (unpoly i) es)
  unpoly i (CApply e es) = CApply (unpoly i e) (map (unpoly i) es)
  unpoly i (CTaskApplyT e t es) = CTaskApplyT (unpoly i e) t (map (unpoly i) es)
  unpoly i (CTaskApply _ _) = internalError "IConv.unpoly: CTaskApply"
  unpoly i (CLit _) = internalError "IConv.unpoly: CLit"
  unpoly i (CBinOp _ _ _) = internalError "IConv.unpoly: CBinOp"
  unpoly i (CHasType _ _) = internalError "IConv.unpoly: CHasType"
  unpoly i (Cif _ _ _ _) = internalError "IConv.unpoly: Cif"
  unpoly i (CSub _ _ _) = internalError "IConv.unpoly: CSub"
  unpoly i (CSub2 _ _ _) = internalError "IConv.unpoly: CSub2"
  unpoly i (CSubUpdate _ _ _ _) = internalError "IConv.unpoly: CSubUpdate"
  unpoly i (Cmodule _ _) = internalError "IConv.unpoly: Cmodule"
  unpoly i (Cinterface pos ii ds) = Cinterface pos ii (map (unpolyd i) ds)
  unpoly i (CmoduleVerilog _ _ _ _ _ _ _ _) = internalError "IConv.unpoly: CmoduleVerilog"
  unpoly i (CForeignFuncC { }) = internalError "IConv.unpoly: CForeignFuncC"
  unpoly i (Cdo _ _) = internalError "IConv.unpoly: Cdo"
  unpoly i (Caction _ _) = internalError "IConv.unpoly: Caction"
  unpoly i (Crules ps rs) = Crules ps (map (unpolyr i) rs)
  unpoly i (COper _) = internalError "IConv.unpoly: COper"
  unpoly i (CCon1 _ _ _) = internalError "IConv.unpoly: CCon1"
  unpoly i (CSelectTT _ _ _) = internalError "IConv.unpoly: CSelectTT"
  unpoly i (CCon0 _ _) = internalError "IConv.unpoly: CCon0"
  unpoly i (CConT t ii es) = CConT t ii (map (unpoly i) es)
  unpoly i (CStructT t ies) = CStructT t (mapSnd (unpoly i) ies)
  unpoly i e@(CSelectT _ _) = e
  unpoly i e@(CLitT _ _) = e
  unpoly i e@(CAnyT {}) = e
  unpoly i (CmoduleVerilogT t e ui clks rsts ses xs v p) = CmoduleVerilogT t (unpoly i e) ui clks rsts (mapSnd (unpoly i) ses) xs v p
  unpoly i e@(CForeignFuncCT { }) = e
  unpoly i (CTApply e ts) = CTApply (unpoly i e) ts
  unpoly i e@(Cattributes ppos) = e
  -- Currently exhaustive - uncomment to kill warning
  -- unpoly i e = internalError ("IConv.unpoly: fell off! :"++(show e))
  
  unpolyd :: Id -> CDefl -> CDefl
  unpolyd i (CLValueSign d qs) = CLValueSign (unpolydd i d) (map (unpolyq i) qs)
  unpolyd i (CLValue _ _ _) = internalError "IConv.unpolyd: CLValue"
  unpolyd i (CLMatch _ _) = internalError "IConv.unpolyd: CLValue"
  
  unpolyr :: Id -> CRule -> CRule
  unpolyr i (CRule ps me qs e) = CRule ps (fmap (unpoly i) me) (map (unpolyq i) qs) (unpoly i e)
  unpolyr i (CRuleNest ps me qs rs) = CRuleNest ps (fmap (unpoly i) me) (map (unpolyq i) qs) (map (unpolyr i) rs)
  
  unpolydd :: Id -> CDef -> CDef
  unpolydd i (CDef _ _ _) = internalError "IConv.unpolydd: CDef"
  unpolydd i (CDefT ii vs t cs) = CDefT ii vs t (map (unpolyc i) cs)
  
  unpolyq :: Id -> CQual -> CQual
  unpolyq i (CQGen t p e) = CQGen t p (unpoly i e)
  unpolyq i (CQFilter e) = CQFilter (unpoly i e)
  
  unpolyc :: Id -> CClause -> CClause
  unpolyc i (CClause ps qs e) = CClause ps (map (unpolyq i) qs) (unpoly i e)
  
  reorderDs :: [CDefl] -> [Id] -> [CDefl]
  reorderDs ds is = map get is
  --        trace ("order: " ++ (ppReadable is) ++ "\n") $
  --        trace ("definitions: " ++ (ppReadable ds) ++ "\n") $
  --        trace ("result: " ++ (ppReadable result) ++ "\n") $ result
    where get i = head [ d | d@(CLValueSign (CDefT i' _ _ _) _) <- ds, i == i' ]
  --        result = map get is
  