Skip to content

Commit 87dae81

Browse files
vidsinghalvidsinghal
committed
nested stack allocated array works, ran works
1 parent 488835e commit 87dae81

File tree

5 files changed

+42
-23
lines changed

5 files changed

+42
-23
lines changed

‎gibbon-compiler/examples/soa_examples/packedTree.hs‎

Lines changed: 6 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -2,6 +2,8 @@ data List = Cons Int List | Nil
22
data FloatList = FCons Float FloatList | FNil
33
data Tree = Node Int Float FloatList List Tree Tree Tree | Leaf
44
{-# ANN type Tree "Factored" #-}
5+
{-# ANN type List "Factored" #-}
6+
{-# ANN type FloatList "Factored" #-}
57

68
mkList :: Int -> List
79
mkList len = if len <= 0
@@ -85,8 +87,9 @@ id :: Tree -> Tree
8587
id tree = tree
8688

8789
gibbon_main =
88-
let tree = mkTree 5
90+
let tree = mkTree 14
8991
tree' = id (add1Tree tree)
90-
val = sumTree tree'
91-
in val
92+
val = iterate (sumTree tree)
93+
r = iterate (rightMostTree tree')
94+
in val + r
9295

‎gibbon-compiler/src/Gibbon/L1/Typecheck.hs‎

Lines changed: 8 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -27,12 +27,14 @@ import Gibbon.Common
2727
import Gibbon.L1.Syntax as L1
2828
import Gibbon.DynFlags
2929
import Prelude hiding (exp)
30+
import Data.Vector.Internal.Check (HasCallStack)
31+
import GHC.Stack (callStack, prettyCallStack)
3032

3133
--------------------------------------------------------------------------------
3234

3335
-- | Typecheck a L1 expression
3436
--
35-
tcExp :: DDefs1 -> Env2 Var Ty1 -> Exp1 -> TcM Ty1 Exp1
37+
tcExp :: HasCallStack => DDefs1 -> Env2 Var Ty1 -> Exp1 -> TcM Ty1 Exp1
3638
tcExp ddfs env exp =
3739
case exp of
3840
VarE v -> lookupVar env v exp
@@ -648,7 +650,7 @@ tcExp ddfs env exp =
648650
then throwError $ GenericTC ("Invalid argument length: " ++ sdoc es) exp
649651
else do
650652
-- Check if arguments match with expected datacon types
651-
sequence_ [ ensureEqualTy e ty1 ty2
653+
sequence_ [ ensureEqualTy e ty1 ty2
652654
| (ty1,ty2,e) <- zip3 args tys es]
653655
return $ PackedTy dcTy loc
654656

@@ -688,7 +690,7 @@ tcExp ddfs env exp =
688690
case ty of
689691
PackedTy tycon _ -> let dd = lookupDDef ddfs tycon
690692
ranTy = getCursorTypeForDataCon ddfs dd
691-
in pure ranTy
693+
in dbgTrace (minChatLvl) "Print ty" dbgTrace (minChatLvl) (sdoc (ty, dd, ranTy)) dbgTrace (minChatLvl) "End printing ty" pure ranTy
692694
_ -> throwError $ GenericTC "Expected a packed argument" exp
693695

694696
MapE{} -> error $ "L1.Typecheck: TODO: " ++ sdoc exp
@@ -704,7 +706,7 @@ tcExp ddfs env exp =
704706

705707
-- | Typecheck a L1 program
706708
--
707-
tcProg :: Prog1 -> PassM Prog1
709+
tcProg :: HasCallStack => Prog1 -> PassM Prog1
708710
tcProg prg@Prog{ddefs,fundefs,mainExp} = do
709711
-- Get flags to check if we're in packed mode
710712
flags <- getDynFlags
@@ -768,11 +770,11 @@ tcProg prg@Prog{ddefs,fundefs,mainExp} = do
768770
let (argTys,retty) = funTy
769771
venv = M.fromList (zip funArgs argTys)
770772
env' = Env2 venv (fEnv env)
771-
res = runExcept $ tcExp ddefs env' funBody
773+
res = runExcept $ tcExp ddefs env' funBody
772774
dynflags <- getDynFlags
773775
let isPacked = gopt Opt_Packed dynflags
774776
case res of
775-
Left err -> error $ sdoc err
777+
Left err -> error $ sdoc err ++ "\n" ++ prettyCallStack callStack
776778
Right ty -> if isPacked && (length $ getPackedTys retty) > 1
777779
then error ("Gibbon-TODO: Functions cannot return multiple packed values; "
778780
++ "check " ++ sdoc funName)

‎gibbon-compiler/src/Gibbon/Language/Syntax.hs‎

Lines changed: 7 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -182,7 +182,13 @@ getCursorTypeForDataCon _ddefs DDef{tyName, dataCons, memLayout} =
182182
PackedTy tycon _ ->
183183
if (toVar tycon) == tyName
184184
then c''
185-
else c'' + 1
185+
else
186+
let ddef_for_tycon = lookupDDef _ddefs tycon
187+
ty_of_packed_field = getCursorTypeForDataCon _ddefs ddef_for_tycon
188+
in case ty_of_packed_field of
189+
CursorTy -> c'' + 1
190+
CursorArrayTy sz -> c'' + sz
191+
_ -> error "Did not expect type"
186192
CursorTy -> c''
187193
CursorArrayTy _ -> c''
188194
_ -> c'' + 1

‎gibbon-compiler/src/Gibbon/Passes/AddRAN.hs‎

Lines changed: 8 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -258,8 +258,14 @@ withRANDDefs needRANsTyCons ddfs = M.map go ddfs
258258
if not (getTyOfDataCon ddfs dcon `S.member` needRANsTyCons)
259259
then acc
260260
else
261-
let ranTy = getCursorTypeForDataCon ddfs dd
262-
tys' = [(False,ranTy) | _ <- [1..n]] ++ tys
261+
let fields = lookupDataCon ddfs dcon
262+
needsRanFields = L.drop (length fields - n) fields
263+
ranTyFields = map (\ty -> case ty of
264+
PackedTy tycon _ -> let dd = lookupDDef ddfs tycon
265+
in getCursorTypeForDataCon ddfs dd
266+
_ -> CursorTy
267+
) needsRanFields
268+
tys' = [(False, r) | r <- ranTyFields] ++ tys
263269
dcon' = toAbsRANDataCon dcon
264270

265271
_tys'' = (False,IntTy) : [(False,IntTy) | _ <- [1..n]] ++ tys

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

Lines changed: 13 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -28,7 +28,6 @@ import qualified Gibbon.L3.Syntax as L3
2828
import Gibbon.NewL2.Syntax
2929
import Gibbon.Passes.AddRAN (numRANsDataCon)
3030
import Text.PrettyPrint.GenericPretty
31-
import Safe (fromJustDef)
3231

3332
{-
3433
@@ -1527,13 +1526,13 @@ cursorizePackedExp freeVarToVarEnv lenv ddfs fundefs denv tenv senv ex =
15271526
-- Vidush: This indexing is actually wrong.
15281527
-- I should make a function that given a position of a loc
15291528
-- get the exact index.
1530-
let (start, end, _) = getIndexPositionOfSoALocVar aft_flocs floc
1529+
-- let (start, end, _) = getIndexPositionOfSoALocVar aft_flocs floc
15311530
(vars, bnds) <- foldlM (\(v, b) i -> do
15321531
new_var <- gensym "unpack_var"
15331532
let bnds = [(new_var, [], CursorTy, Ext $ IndexCursorArray var_name i)]
15341533
return $ (v ++ [new_var], b ++ bnds)
15351534

1536-
) ([], []) [start..(end - 1)]
1535+
) ([], []) [0..(sz - 1)]
15371536
return $ res ++ [(vars, bnds)]
15381537
) [] aft_flocs
15391538
let after_flocs_to_vars = concatMap fst res
@@ -2375,12 +2374,13 @@ cursorizeLocExp freeVarToVarEnv denv tenv senv lvar locExp =
23752374
Single{} -> return $ (Ext $ IndexCursorArray loc_var (1 + elem_idx), [])
23762375
SoA _ fregs -> do
23772376
let CursorArrayTy sz = getCursorizeTyFromLocVar field_loc
2378-
let start = L.elemIndex (i, field_loc) field_locs
2379-
let start_val = fromJustDef (-1) start
2377+
let (start, end, _) = getIndexPositionOfSoALocVar field_locs field_loc
2378+
--let start = L.elemIndex (i, field_loc) field_locs
2379+
--let start_val = fromJustDef (-1) start
23802380
res <- foldlM (\bnds i -> do
23812381
new_var <- gensym "unpack_loc"
23822382
return $ bnds ++ [ (new_var, (new_var, [], CursorTy, Ext $ IndexCursorArray loc_var i)) ]
2383-
) [] [(start_val + 1)..(start_val + sz)]
2383+
) [] [(start)..(end - 1)]
23842384
let vars = map fst res
23852385
let bnds = map snd res
23862386
return $ (Ext $ MakeCursorArray (length vars) vars, bnds)
@@ -2462,12 +2462,13 @@ cursorizeRegExp freeVarToVarEnv denv tenv senv lvar regExp =
24622462
Single{} -> return $ (Ext $ IndexCursorArray loc_var (1 + elem_idx), [])
24632463
SoA _ fregs -> do
24642464
let CursorArrayTy sz = getCursorizeTyFromLocVar field_loc
2465-
let start = L.elemIndex (i, field_loc) field_locs
2466-
let start_val = fromJustDef (-1) start
2465+
let (start, end, _) = getIndexPositionOfSoALocVar field_locs field_loc
2466+
--let start = L.elemIndex (i, field_loc) field_locs
2467+
--let start_val = fromJustDef (-1) start
24672468
res <- foldlM (\bnds i -> do
24682469
new_var <- gensym "unpack_loc"
24692470
return $ bnds ++ [ (new_var, (new_var, [], CursorTy, Ext $ IndexCursorArray loc_var i)) ]
2470-
) [] [(start_val + 1)..(start_val + sz)]
2471+
) [] [(start)..(end-1)]
24712472
let vars = map fst res
24722473
let bnds = map snd res
24732474
return $ (Ext $ MakeCursorArray (length vars) vars, bnds)
@@ -2628,12 +2629,13 @@ cursorizeAppE freeVarToVarEnv lenv ddfs fundefs denv tenv senv ex =
26282629
let (idx, _, _) = getIndexPositionOfSoARegVar fieldRegions field_reg
26292630
pure (vs ++ [v], bds ++ [(v, [], CursorTy, Ext $ IndexCursorArray v idx)])
26302631
SoARv{} -> do
2631-
let (start, end, _) = getIndexPositionOfSoARegVar fieldRegions field_reg
2632+
--let (start, end, _) = getIndexPositionOfSoARegVar fieldRegions field_reg
2633+
let CursorArrayTy _sz = getCursorizeTyFromRegVar field_reg
26322634
(nvars, bnds) <- foldlM (\(nv, bnd) i -> do
26332635
var_n <- gensym "unpack"
26342636
return (nv ++ [var_n], bnd ++ [(var_n, [], CursorTy, Ext $ IndexCursorArray v i)])
26352637

2636-
) ([], []) [start ..(end - 1)]
2638+
) ([], []) [0 ..(_sz - 1)]
26372639
pure (vs ++ nvars, bds ++ bnds)
26382640
)
26392641
([], [])

0 commit comments

Comments
 (0)