Make sure output locations are re-written to in redirection case

Author: vidsinghal

gibbon-compiler/examples/simple_tests/tree.hs

@@ -30,7 +30,7 @@ sumTree tr =
 
 gibbon_main = 
    let tree = mkTree 10
-       -- _ = printPacked tree
+       --_ = printPacked tree
        tree' = add1Tree tree 
        --_ =  printPacked tree'
        val = sumTree tree'
@@ -40,4 +40,4 @@ gibbon_main =
        rmost = rightmost tree'
        _ = printint rmost
        _ = printsym (quote ")\n\n")
-     in sumTree tree'
+     in () --sumTree tree

gibbon-compiler/src/Gibbon/Passes/Cursorize.hs

@@ -2707,7 +2707,7 @@ unpackDataCon dcon_var freeVarToVarEnv lenv ddfs fundefs denv1 tenv1 senv isPack
                                    (toEndFromTaggedV redirection_var_dcon, [], CursorTy, Ext $ AddCursor redirection_var_dcon (VarE (toTagV redirection_var_dcon)))]
 
                           --generate binds for all fields.
-                          binds_flields = L.foldr (\((_, idx), var) (index, res) -> let read_cursor_f = if isIndirectionTag dcon || isRedirectionTag dcon
+                          binds_flields = L.foldl (\(index, res) ((_, idx), var) -> let read_cursor_f = if isIndirectionTag dcon || isRedirectionTag dcon
                                                                                                          then Ext (ReadTaggedCursor (vars_next_fields !! index))
                                                                                                          else error $ "unpackRegularDataCon: cursorty without indirection/redirection."
                                                                                         tmpf = tmp_flds !! index          

gibbon-compiler/src/Gibbon/Passes/FollowPtrs.hs

@@ -5,13 +5,14 @@ module Gibbon.Passes.FollowPtrs
 import qualified Data.Map as M
 -- import qualified Data.Set as S
 import qualified Data.List as L
--- import           Data.Foldable ( foldrM )
+import           Data.Foldable ( foldrM )
 import           Data.Maybe ( fromJust )
 
 import           Gibbon.Common
 import           Gibbon.Language
 import           Gibbon.L2.Syntax as L2
 import Gibbon.DynFlags
+import Gibbon.L3.Syntax (E3Ext(AddCursor))
 
 --------------------------------------------------------------------------------
 
@@ -66,12 +67,44 @@ followPtrs (Prog ddefs fundefs mainExp) = do
               -- because bounds checking may have updated the value of the location.
               -- Note that we only need to update the non packed locations + the data constructor buffer.
               -- Other packed types will be updated by the function that traverses it.
+              (new_out_locs, new_loc_bnds) <- foldrM (\locvar (nl, bnds) -> case locvar of 
+                                                                                  SoA dloc flocs -> do 
+                                                                                              -- unpack all locations in the SoA location. 
+                                                                                              let unpack_dcon = LetLocE (singleLocVar dloc) (GetDataConLocSoA locvar)
+                                                                                              let unpack_flds = map (\((dcon, idx), floc) -> do 
+                                                                                                                                              let flet = LetLocE floc (GetFieldLocSoA (dcon, idx) locvar) 
+                                                                                                                                               in flet
+                                                                                                                    ) flocs
+                                                                                              -- make a new name for this loc_var
+                                                                                              new_locvar <- freshCommonLoc "copy" locvar
+                                                                                              let new_don_loc = getDconLoc new_locvar
+                                                                                              -- The data con loc should be unpacked and updated by bounds check. 
+                                                                                              -- from design of the compiler 
+                                                                                              let new_don_let = LetLocE new_don_loc (AfterConstantLE 0 (singleLocVar dloc))
+                                                                                              let new_fld_locs = getAllFieldLocsSoA new_locvar
+                                                                                              new_fld_lets <- foldrM (\((dcon, idx), nfloc) flts -> do 
+                                                                                                                                                let ty = (lookupDataCon ddefs dcon) !! idx
+                                                                                                                                                  in case (ty) of
+                                                                                                                                                            PackedTy{} -> do 
+                                                                                                                                                                  let let_for_fld = LetLocE nfloc (GetFieldLocSoA (dcon, idx) locvar)
+                                                                                                                                                                   in pure $ flts ++ [let_for_fld]
+                                                                                                                                                            _ -> do 
+                                                                                                                                                                  let let_for_fld = LetLocE nfloc (AfterConstantLE 0 (getFieldLoc (dcon, idx) locvar))
+                                                                                                                                                                    in pure $ flts ++ [let_for_fld]
+                                                                                                                                                       ) [] new_fld_locs
+                                                                                              let new_soa_loc_let = LetLocE new_locvar (GenSoALoc new_don_loc new_fld_locs)
+                                                                                              return $ (nl ++ [new_locvar], bnds ++ [unpack_dcon] ++ unpack_flds ++ [new_don_let] ++ new_fld_lets ++ [new_soa_loc_let]) 
+                                                                                         
+                                                                                  -- no need to update single location variables
+                                                                                  Single{} -> return $ (nl ++ [locvar], bnds)
+                                                     ) ([], [])  out_locs
 
               let redir_dcon = fst $ fromJust $ L.find (isRedirectionTag . fst) dataCons
               let redir_bod = (if isPrinterName funName then LetE (wc,[],ProdTy[],PrimAppE PrintSym [LitSymE (toVar " ->r ")]) else id) $
-                              LetE (callv,endofs,out_ty,AppE funName (in_locs ++ out_locs) args) $
+                              LetE (callv,endofs,out_ty,AppE funName (in_locs ++ new_out_locs) args) $
                               Ext (RetE endofs callv)
-              let redir_br = (redir_dcon,[(indir_ptrv,(indir_ptrloc))],redir_bod)
+              let redir_bod' = foldr (\bnd bod -> Ext $ bnd bod) redir_bod new_loc_bnds
+              let redir_br = (redir_dcon,[(indir_ptrv,(indir_ptrloc))],redir_bod')
               ----------------------------------------
               (pure (CaseE scrt (brs ++ [redir_br])))
             else do