{-# LANGUAGE QuasiQuotes, TemplateHaskell, BangPatterns #-}
module Language.Floorplan.Rust.Compiler
( genRust, writeModule
) where
import System.IO (IOMode(..), openFile, hClose)
import Data.Typeable (Typeable(..))
import Language.Rust.Parser as P
import Language.Rust.Syntax as R
import Language.Rust.Quote
import Language.Rust.Data.Ident
import Language.Rust.Data.Position
import Language.Floorplan.Core.Syntax
import Data.Bifunctor ( bimap )
import Data.Functor ( ($>) )
import Data.Ord (comparing)
import Data.List (sortBy, nub, inits)
import Data.Char (toUpper, toLower)
import Data.Maybe (isJust, fromMaybe)
import Data.Bits
import qualified Debug.Trace as D
import Language.Rust.Pretty (writeSourceFile)
import Language.Floorplan.Rust.Types
import Language.Floorplan.Rust.Mapping
import Language.Floorplan.Rust.Common
import Language.Floorplan.Syntax(SizeArith(..), Primitive(..), FlagID(..))
moduleToItems :: RustItem -> [Item Span]
moduleToItems (RustImpl n is outer_is) =
nub outer_is ++
[ Impl [] InheritedV Final Normal Positive
(Generics [] [] (WhereClause [] fS) fS) Nothing (mkTy n) (nub is) fS
]
moduleToItems (TopLevel is) = is
--(mkIdent n) (Just $ nub is) fakeSpan
-- | TODO: modules with same name should be merged into one.
mergeImpls :: [RustItem] -> [Item Span]
mergeImpls ms = let
merge [] = []
merge (x:[]) = [x]
merge (x@(RustImpl xN xIS xOuter):y@(RustImpl yN yIS yOuter):ys)
| xN == yN = merge $ (RustImpl xN (xIS ++ yIS) (xOuter ++ yOuter)) : ys
| otherwise = x : merge (y:ys)
merge (x@(TopLevel ns):y@(TopLevel ns'):ys) =
merge $ (TopLevel $ ns ++ ns') : ys
merge (x:y:ys) = x : merge (y : ys)
in concatMap moduleToItems $ merge $ sortBy (comparing rustItemComparator) ms
genRust :: [BaseExp] -> SourceFile Span
genRust bes =
SourceFile Nothing headerAttrs $
headerItems
++ genFixedWidthStructs bes
++ (mergeImpls $
genStaticOffsets bes
++ genEnumAll' bes
++ genFieldPtrGetters bes
++ genMaps bes
++ genContainsMethods bes
++ genGetFirstMethods bes
++ genBitsAccessors bes
++ genDynamicSkippers bes
++ genAddrAddr bes
++ genNeighborParents bes
++ genDistributeContainsAttr bes
++ genEnumAccessors bes
++ genShadowAlloc bes
++ genStoreWord bes
-- TODO: Check whether a RemainderAddr occurs *after* a LimitAddr, i.e. when the LHS
-- of two sequential named fields occurs at an address greater than the address of
-- the thing on the RHS, it's clearly malformed (i.e. the RTS speculatively made
-- a new address, but realized that it's not allowed - TODO: eventually want some
-- way to enforce, e.g. with types, the developer turns a "Speculative" address
-- into a "Real" one, and that speculative addresses get generated for methods here
-- that can't know for sure they'll produce pointers to valid things, but that
-- can be "marked" as valid by doing a check).
)
-- | Must return a nonempty list
findAlignment :: BaseExp -> [Int]
findAlignment (Prim{}) = [1]
findAlignment (Con _ e) = findAlignment e
findAlignment (_ :@ align) = [align]
findAlignment (e :+ _) = findAlignment e -- Alignment of first thing
findAlignment (e1 :|| e2) =
let a1 = findAlignment e1
a2 = findAlignment e2
in a1 ++ a2
findAlignment (_ ::: e) = findAlignment e
findAlignment (Exists _ e) = findAlignment e
findAlignment (_ :# e) = findAlignment e -- Alignment of first repetition
findAlignment (Attr _ e) = findAlignment e
-- | Generate the items associated with an Impl, as necessary for
-- making a new e.g. `FooAddr` type.
genAssocItems :: NameID -> BaseExp -> [Item Span]
genAssocItems n e =
let nAddr = addrName n
nAddrEnd = addrEndName n
-- TODO: Alignment should conservatively be a list, not just the smallest one found
-- (to detect alignment errors from a pointer as precisely as possible,
-- though non-power-of-two alignments are rare / uncommon, so choosing
-- the smallest one is likely sufficient for most use cases):
bytesAlign = bytesAlignName n
sz = expSize e
(Just sz') = expSize e
bytes = [items| pub const ${i| bytesName n |} : usize = ${e| mkIntExp sz' |}; |]
consAlign = foldl mini 0 $ findAlignment e
alignConst = [items| pub const $bytesAlign : usize = 1 << ${i| logAlignName n |}; // ${e| mkIntExp consAlign |}; |]
alignConst' = [items| pub const $bytesAlign : usize = ${e| mkIntExp consAlign |}; |]
logAlign
| isPow2 consAlign = [items| pub const ${i| logAlignName n |} : usize = ${e| mkIntExp $ log2 consAlign |}; |] ++ alignConst
| otherwise = alignConst'
logBytes
| isJust sz && isPow2 sz' =
bytes
++ [items| pub const ${i| logBytesName n |} : usize = ${e| mkIntExp $ log2 sz' |};
|]
| isJust sz = bytes
| otherwise = []
-- | Ignore the zero
mini x 0 = x
mini 0 x = x
mini x y = min x y
in logAlign ++
[items| #[repr (C)]
#[derive(Copy, Clone, Eq, Hash)]
pub struct $nAddr(usize);
deriveAddr!($nAddr, $bytesAlign);
#[repr (C)]
#[derive(Copy, Clone, Eq, Hash)]
pub struct $nAddrEnd(usize);
deriveAddr!($nAddrEnd, 1);
|] ++ logBytes
genEnumAll :: (Int, (NameID, BaseExp)) -> RustItem
genEnumAll (i, (n, e)) =
let nEnum = enumName n
in RustImpl (addrName n) []
[items| pub const $nEnum : u8 = ${e| mkIntExp i |};
|]
mkNameStringExp :: (NameID, BaseExp) -> Expr Span
mkNameStringExp (n, _) = Lit [] (Str (allUpper n) Cooked Unsuffixed fakeSpan) fakeSpan
genFLPArray :: [(NameID, BaseExp)] -> RustItem
genFLPArray nes = TopLevel
[items| pub const __FLP_IDX_UNMAPPED : u8 = 0;
pub const __FLP_TYPES: &'static [&'static str] = & ${e| Vec []
(mkNameStringExp ("UNMAPPED", undefined) : map mkNameStringExp nes) fakeSpan |}; |]
genStoreWord :: [BaseExp] -> [RustItem]
genStoreWord bes = let
gSW :: BaseExp -> Maybe RustItem
gSW (n ::: e) = do
sz <- expSize e
if sz == bytesInWord then return
(RustImpl (addrName n)
(snd [implItems|
pub fn store_word(&self, val: usize) {
self.store::<usize>(val);
}
|])
[])
else Nothing
gSW rest = Nothing
genStoreStruct :: BaseExp -> Maybe RustItem
genStoreStruct (n ::: e) = do
sz <- expSize e
let sN = structName n
let store_struct = fieldStructSetterName n
let load_struct = fieldStructGetterName n
return (RustImpl (addrName n)
(snd [implItems|
pub fn $store_struct(&self, val: $sN) {
self.store::<$sN>(val);
}
pub fn $load_struct(&self) -> $sN {
self.load::<$sN>()
} |]) [])
genStoreStruct _ = Nothing
in concatMap (accum genStoreStruct) bes ++ concatMap (accum gSW) bes
genEnumAll' :: [BaseExp] -> [RustItem]
genEnumAll' bes =
let findNames :: BaseExp -> Maybe (NameID, BaseExp)
findNames (n ::: e) = Just (n, e)
findNames _ = Nothing
in genFLPArray (nub $ concatMap (accum findNames) bes)
: map genEnumAll (zip [1 :: Int .. ] (nub $ concatMap (accum findNames) bes))
-- [Item ()]
genStaticOffsets :: [BaseExp] -> [RustItem]
genStaticOffsets bes =
let
--(NameID, [ImplItem Span])
findSO :: BaseExp -> Maybe RustItem
findSO (n ::: e2) = Just $ RustImpl (addrName n) (concat $ l2r (mkN n) e2) (genAssocItems n e2)
findSO _ = Nothing
-- Finds all "neighboring" named subexpressions that are a static
-- distance from the beginning of the subexpression.
mkN :: NameID -> Maybe Nat -> BaseExp -> Maybe [ImplItem Span]
mkN _ Nothing _ = Nothing
mkN nOuter (Just k) (n ::: _) = Just $
let aN = addrName n
oN = offsetName n
gN = getterName n
rev_gN = reverseGetterName n
aNOuter = addrName nOuter in
-- TODO: [items| |] quasiquoter for multiple items
snd [implItems|
pub const ${i|oN|}: usize = ${e| mkIntExp k |};
pub fn $gN(&self) -> $aN {
self.plus::<$aN>($aNOuter :: $oN)
}
pub fn $rev_gN(addr: $aN) -> $aNOuter {
addr.sub::<$aNOuter>($aNOuter :: $oN)
}
|]
--[item| const FOO: usize = 22; |]
mkN _ _ _ = Nothing
in concatMap (accum findSO) bes
genFieldPtrGetters :: [BaseExp] -> [RustItem]
genFieldPtrGetters bes = let
findFieldPtr :: BaseExp -> Maybe RustItem
findFieldPtr (n ::: (Attr (BaseType (PtrBT field)) blob)) =
let aN = addrName n
get_field = fieldPtrGetterName field
set_field = fieldPtrSetterName field
newAddr = addrName field in
Just $ RustImpl (addrName n)
(snd $ [implItems|
pub fn $get_field(self) -> $newAddr {
let ret = self.load::<$newAddr>();
//backtraceHere!(ret);
ret
}
pub fn $set_field(self, val : $newAddr) {
//backtraceHere!(val);
self.store::<$newAddr>(val)
}
|])
[]
findFieldPtr _ = Nothing
in concatMap (accum findFieldPtr) bes
-- | Distribute the 'contains(...)' attributes on layers onto all of the named fields
-- (and other layers) one-level-deep (don't traverse the AST through names), such that
-- we get out conversion functions to/from the "contained" thing and the inner names found.
-- These casting functions get associated with the container itself, not the addresses
-- being cast so as to keep how the contains() attribute works simple to understand.
--
-- TODO: We can do *all* sorts of assertions here, such as checking alignment constraints
-- e.g. if you cast an immix Cell to an immix Line, then that Cell *should* have started
-- on an aligned-Line. If this was not the case, either there was an error, or we should
-- provide support for optional types that fail when alignment fails. It's probably better
-- for now though to just require that the system developer check alignment constraints
-- on there own and have FLP print out an error message when alignments are broken, that way
-- we can figure out what to do with bad alignments when we have an actual example.
genDistributeContainsAttr :: [BaseExp] -> [RustItem]
genDistributeContainsAttr bes = let
findNamed :: BaseExp -> Maybe RustItem
findNamed (n ::: e) = Just $ RustImpl (structName n) (mkDistr e) []
findNamed _ = Nothing
mkDistr :: BaseExp -> [ImplItem Span]
mkDistr (Attr (Contains nCont) e) = distribute nCont e ++ mkDistr e -- Distribute 'contains()' things
mkDistr (n ::: _) = [] -- Only go one level of naming deep.
mkDistr e = callSub mkDistr e -- Recursive call on subexpressions
distribute :: NameID -> BaseExp -> [ImplItem Span]
distribute nCont (nInner ::: eInner) = let
cast_from1 = castFromName nCont nInner
cast_from2 = castFromName nInner nCont
nContA = addrName nCont
nInnerA = addrName nInner
in (snd $
[implItems|
pub fn $cast_from1(addr : $nContA) -> $nInnerA { $nInnerA::from_usize(addr.as_usize()) }
pub fn $cast_from2(addr : $nInnerA) -> $nContA { $nContA::from_usize(addr.as_usize()) }
|]) ++ distribute nCont eInner
distribute nCont e = callSub (distribute nCont) e
in concatMap (accum findNamed) bes
genContainsMethods :: [BaseExp] -> [RustItem]
genContainsMethods bes = let
findNamed :: BaseExp -> Maybe RustItem
findNamed (n ::: e) = Just $ RustImpl (addrName n) (concat $ l2r (mkContains n) e) []
findNamed _ = Nothing
-- Make the 'name_contains()' methods for appropriate subexpressions
mkContains :: NameID -> Maybe Nat -> BaseExp -> Maybe [ImplItem Span]
mkContains nOuter sz (nInner ::: _) = Just $
let containsFn = containsFnName nInner
innerAddr = addrName nInner
outerAddrEnd = addrEndName nOuter
in snd $
[implItems| pub fn $containsFn(&self, addr: $innerAddr, end: $outerAddrEnd) -> bool {
addr.as_usize() >= self.as_usize() && addr.as_usize() < end.as_usize()
}
|]
mkContains _ _ _ = Nothing
in concatMap (accum findNamed) bes
genBitsAccessors :: [BaseExp] -> [RustItem]
genBitsAccessors bes = let
-- overall size (bytes) -> (curr offset, accumulated) -> (Field Name, Field Size (bits)) -> Result
-- (b -> a -> b)
singleField :: Nat -> (Int, [ImplItem Span]) -> (NameID, Int) -> (Int, [ImplItem Span])
singleField sz (curr_offset, accum) (fieldName, bits)
| bits == 0 = (curr_offset, accum) -- No bits - continue on (no accessor).
| bits < bitsInByte && sz == 1 = -- 1-7 bits, no byte-offsets required (because sz==1):
let getter = bitsGetterName bits fieldName
fieldNameLow = fieldName ++ "_LOW_BIT"
fieldNameBits = fieldName ++ "_NUM_BITS"
fieldNameMask = fieldName ++ "_MASK"
fromer = bitsFromerName bits fieldName
getterItem
| bits == 1 =
[implItems| pub fn $getter(&self) -> bool { ((self.0[0]) & Self::$fieldNameMask) > 0 }
pub fn $fromer(b : bool) -> Self { Self([(b as u8) << Self::$fieldNameLow]) }
|]
| otherwise =
[implItems| pub fn $getter(&self) -> u8 { (self.0[0]) & Self::$fieldNameMask }
pub fn $fromer(v : u8) -> Self { Self([v]) }
|]
in (curr_offset + bits, (snd $
[implItems|
pub const $fieldNameLow : usize = ${e| mkIntExp curr_offset |};
pub const $fieldNameBits : usize = ${e| mkIntExp bits |};
pub const $fieldNameMask : u8 = ${e| mkBinExp $ ((1 `shiftL` (curr_offset + bits)) - 1) .&. (complement ((1 `shiftL` curr_offset) - 1)) |};
|]) ++ snd getterItem ++ accum)
| bits == bitsInByte && sz == 1 = -- No offset required, whole byte:
let getter = bitsGetterName bits fieldName
fromer = bitsFromerName bits fieldName
fieldNameBits = fieldName ++ "_NUM_BITS"
in (curr_offset + bits, (snd $
[implItems| pub fn $getter(&self) -> u8 { self.0[0] }
pub fn $fromer(v : u8) -> Self { Self([v]) }
pub const $fieldNameBits : usize = ${e| mkIntExp bits |};
|]) ++ accum)
| otherwise = error $ "TODO: sz=" ++ show sz ++ ", bits=" ++ show bits
-- Returns ([inside the impl], [outside the impl])
findBitsExp :: BaseExp -> Maybe ([ImplItem Span], [Item Span])
findBitsExp (Con _ e) = findBitsExp e
findBitsExp (e :@ _) = findBitsExp e
findBitsExp (Exists _ e) = findBitsExp e
findBitsExp (Attr (BaseType (BitsBT fs)) (Prim sz))
| sz > 0 = Just $ (snd $ foldl (singleField sz) (0, []) fs, [])
| otherwise = Nothing
findBitsExp _ = Nothing
findNamedBitsExps (name ::: e) = (uncurry $ RustImpl (structName name)) <$> findBitsExp e
findNamedBitsExps _ = Nothing
in concatMap (accum findNamedBitsExps) bes
genEnumAccessors :: [BaseExp] -> [RustItem]
genEnumAccessors bes = let
findEnums :: BaseExp -> Maybe [RustItem]
findEnums (n ::: (Attr (BaseType (EnumBT fs)) (Prim sz))) = Just $ [ RustImpl (structName n) (mkEnumFns fs sz) [] ]
findEnums _ = Nothing
mkEnumFns :: [FlagID] -> Nat -> [ImplItem Span]
mkEnumFns fs sz = let
valType
| sz == 1 = "u8"
| sz == 2 = "u16"
| sz == 4 = "u32"
| sz == 8 = "u64"
| otherwise = error $ "Unhandled size=" ++ show sz
in snd
[implItems|
#[inline(always)]
pub fn from_enum(val : $valType) -> Self { Self([val]) }
#[inline(always)]
pub fn to_enum(&self) -> $valType { self.0[0] }
|]
in concat $ concatMap (accum findEnums) bes
-- pub fn from_enum(val : u8) -> Self { LineMark([val]) }
genDynamicSkippers :: [BaseExp] -> [RustItem]
genDynamicSkippers bes = let
findDynamic :: BaseExp -> Maybe [RustItem]
findDynamic (_ :# e) = Just $ iterators (expSize e) (names e) (names e)
findDynamic _ = Nothing
names (e1 :|| e2) = names e1 ++ names e2
names (n ::: e) = n : names e
names (Con _ e) = names e
names (e :@ _) = names e
names (e1 :+ e2)
| expSize e2 == Just 0 = names e1
| otherwise = []
names (Exists _ e) = names e
names (_ :# _) = []
names (Attr _ e) = names e
names (Prim{}) = []
iterators _ _ [] = []
iterators s@Nothing ns (n':ns') = let
skipper name =
let addrN = addrName name
skName = skipperName name
in snd $ [implItems| pub fn $skName(&self, bytes : usize) -> $addrN { self.plus(bytes) } |]
in (RustImpl (addrName n') (concatMap skipper ns) []) : (iterators s ns ns')
iterators s@(Just sz) ns (n':ns') = let
jumper name =
let addrN = addrName name
jmpName = jumperName name
bytesInThing = bytesName n'
logBytesInThing = logBytesName n'
in snd $
if isPow2 sz
then [implItems|
pub fn $jmpName(&self, count : usize) -> $addrN {
self.plus(count << $logBytesInThing)
} |]
else [implItems|
pub fn $jmpName(&self, count : usize) -> $addrN {
self.plus($bytesInThing * count)
} |]
in (RustImpl (addrName n') (concatMap jumper ns) []) : (iterators s ns ns')
findNamed :: BaseExp -> Maybe [RustItem]
findNamed (n ::: e) = innerPound n e
findNamed _ = Nothing
innerPound :: NameID -> BaseExp -> Maybe [RustItem]
innerPound n (Exists _ e) = innerPound n e
innerPound n (_ :# e) = Just $ [ RustImpl (addrName n) (fixedSzIters e) [] ]
innerPound _ _ = Nothing
fixedSzIters :: BaseExp -> [ImplItem Span]
fixedSzIters (Attr (BaseType (PtrBT ptrT)) _) =
let aName = addrName ptrT
aaName = addrName aName
nxtName = nextName ptrT
firstName = firstGetterName aaName
in snd $
[implItems| pub fn $nxtName(ptr: $aaName) -> $aaName { ptr.plus(BYTES_IN_WORD) }
pub fn $firstName(&self) -> $aaName { $aaName(self.as_usize()) }
|]
fixedSzIters (e1 :|| e2) = fixedSzIters e1 ++ fixedSzIters e2
fixedSzIters (n ::: _) = []
fixedSzIters (Con _ e) = fixedSzIters e
fixedSzIters (e1 :+ e2)
| expSize e2 == Just 0 = fixedSzIters e1
| otherwise = []
fixedSzIters (Exists _ e) = fixedSzIters e
fixedSzIters (_ :# _) = []
fixedSzIters (Prim {}) = []
fixedSzIters (Attr _ e) = fixedSzIters e
in (concat $ concatMap (accum findDynamic) bes) ++ (concat $ concatMap (accum findNamed) bes)
genAddrAddr :: [BaseExp] -> [RustItem]
genAddrAddr bes = let
findPtrBT (Attr (BaseType (PtrBT ptrT)) _) =
let aName = addrName ptrT
aaName = addrName aName
bytesAlign = bytesAlignName aName
getter = getterName aName
in Just $ RustImpl aaName
(snd $ [implItems|
pub fn $getter(&self) -> $aName { self.load() }
|])
[items| #[repr (C)]
#[derive(Copy, Clone, Eq, Hash)]
pub struct $aaName(usize);
pub const $bytesAlign : usize = 1;
deriveAddr!($aaName, $bytesAlign); |]
findPtrBT _ = Nothing
in concatMap (accum findPtrBT) bes
-- | Finds all the NameIDs for which the first (possibly only) instance of some NameID
-- occurs flush with the beginning of the top-level expression (zero bytes distance
subexpFirsts :: BaseExp -> [NameID]
subexpFirsts be = let
-- INVARIANT of sF: never call on a subexpression that doesn't *start* at the
-- beginning of the outer-most expression 'be'.
sF (n ::: e) = n : sF e
sF (Attr (Contains n) e) = n : sF e
sF (Attr (BaseType (SizeBT (SizeLit Nothing p))) (Prim{})) = [show p]
sF (Prim{}) = []
sF (Con _ e) = sF e
sF (e :@ _) = sF e
sF (e1 :+ e2)
| expSize e1 == Just 0 = sF e1 ++ sF e2
| otherwise = sF e1 -- Conservative approximation (ignore things in e2 even though expSize is conservative)
sF (e1 :|| e2) = sF e1 ++ sF e2
sF (Exists _ e) = sF e
sF (_ :# e) = sF e -- First instances of 'e' is in 'subexpFirsts be'
sF (Attr _ e) = sF e
in sF be
genGetFirstMethods :: [BaseExp] -> [RustItem]
genGetFirstMethods bes = let
findNamed :: BaseExp -> Maybe RustItem
findNamed (n ::: e) = Just $ RustImpl (addrName n) (concatMap mkGetFirst $ subexpFirsts e) []
findNamed _ = Nothing
mkGetFirst n = let
get_first = firstGetterName n
aN = addrName n
in snd [implItems|
pub fn $get_first(self) -> $aN {
$aN::from_usize(self.as_usize())
} |]
in concatMap (accum findNamed) bes
type NamedE = (NameID, BaseExp)
type Neighbors = (NamedE, NamedE)
-- | Makes a plain-vanilla pass-by-value paramument with the given type:
mkParam :: BindingMode -> String -> String -> Arg Span
mkParam mode var ty = Arg (Just $ IdentP mode (mkIdent var) Nothing fS) (PathTy Nothing (Path False [PathSegment (mkIdent ty) Nothing fS] fS) fS) fS
mkSelf = SelfRegion Nothing Immutable fS
-- | Makes a plain-vanilla type from a name
mkRustTy :: String -> Ty Span
mkRustTy name = PathTy Nothing (Path False [PathSegment (mkIdent name) Nothing fS] fS) fS
-- List is /all/ the ancestral parents in bottom-up order. NamedE is the child who
-- has the ancesters.
type Ancestry = ([NamedE], NamedE)
genShadowAlloc :: [BaseExp] -> [RustItem]
genShadowAlloc bes = let
findParentList :: BaseExp -> [Ancestry]
findParentList be = let
-- acc is list of parents accumulator along the path from the root to the given BaseExp
fPL :: [NamedE] -> BaseExp -> [Ancestry]
fPL acc (prnt ::: e) = (acc, (prnt, e)) : (fPL ((prnt,e) : acc) e)
fPL acc e = callSub (fPL acc) e
in fPL [] be
filterAncestry :: [Ancestry] -> [Ancestry]
filterAncestry [] = []
filterAncestry ((prnts, (cN, cE)) : rest) = let
matchingRest :: [Ancestry]
matchingRest = filter ((== cN) . fst . snd) rest
notMatchingRest :: [Ancestry]
notMatchingRest = filter ((/= cN) . fst . snd) rest
allPrnts = (prnts ++ (concatMap fst matchingRest))
in (nub allPrnts, (cN, cE)) : filterAncestry notMatchingRest
mkShadowAlloc :: Ancestry -> [RustItem]
mkShadowAlloc (prnts, child) = let
nBytesIn = bytesName (fst child)
flp_IDX_NAME = enumName (fst child)
mkRustName :: NameID -> Expr Span
mkRustName n = [expr| $n |]
mkInner =
-- Static u8 (indices / IDXs) array of the parents of this child
snd [implItems|
pub const __FLP_IDX : u8 = $flp_IDX_NAME;
pub const __FLP_PARENTS : &'static [u8] = & ${e| Vec []
(map mkRustName $ (map (enumName . fst) prnts) ++ [enumName "UNMAPPED"]) fakeSpan |}; |]
++ (case expSize (snd child) of
Nothing -> -- Variable-size child - caller needs to indicate size
snd [implItems|
pub fn shadow_alloc_from(&self, bytes: usize, vec_IDX: Vec<u8>) {
//assert!(Self::__FLP_PARENTS.contains(&IDX));
//for i in 0 .. bytes {
// let offset = self.as_usize() + i;
// check_expect_pc!(offset, &vec_IDX);
//}
}
|]
Just sz -> if sz == 0 then [] -- Cannot actually shadow allocate something of zero size (no-op)
else -- Fixed-size child: caller need not indicate the size
snd [implItems|
pub fn shadow_alloc_from(&self, vec_IDX: Vec<u8>) {
//assert!(Self::__FLP_PARENTS.contains(&IDX));
//for i in 0 .. $nBytesIn {
// let offset = self.as_usize() + i;
// check_expect_pc!(offset, &vec_IDX);
//}
} |])
in [RustImpl (addrName $ fst child) mkInner [] ]
in concatMap mkShadowAlloc (filterAncestry $ concatMap findParentList bes)
-- in undefined -- concat $ concatMap (accum findParentList) bes
-- | Generate all things pertaining to neighboring names, along with their common parent name.
genNeighborParents :: [BaseExp] -> [RustItem]
genNeighborParents bes = let
findParent :: BaseExp -> Maybe [RustItem]
findParent (prnt ::: e) = Just $ mkItems prnt (findNeighbors e)
++ fromMaybe [] (mkSeqFns prnt <$> (findSeqs False e))
++ mkAddrEndDiff prnt
++ fromMaybe [] (mkAllocShadow prnt <$> (findSeqs True e))
findParent _ = Nothing
-- Find the canonical sequence of named things
findSeqs :: Bool -> BaseExp -> Maybe [NamedE]
findSeqs unwrapAll be = let
findS :: BaseExp -> Maybe [NamedE]
findS (Con _ e) = findS e
findS (e :@ _) = findS e
findS (Exists _ e) = findS e
findS (Attr _ e) = findS e
findS (e1 :+ e2) = findS e1 >>= \a -> findS e2 >>= \b -> pure (a ++ b)
findS (n ::: e) = Just $ [ (n,e) ]
findS (e1 :|| e2)
| unwrapAll = findS e1 >>= \a -> findS e2 >>= \b -> pure (a ++ b)
| otherwise = Nothing
findS (_ :# e)
| unwrapAll = findS e
| otherwise = Nothing
findS (Prim{}) = Nothing
in findS be
-- | Individually named shadow_alloc_from_*() functions, i.e. for each parent.
mkAllocShadow :: NameID -> [NamedE] -> [RustItem]
mkAllocShadow prnt nes = let
shadow_alloc_fn = "shadow_alloc_from_" ++ firstLower prnt
mkImpl ne = RustImpl (addrName $ fst ne) (inner ne) []
prntConstFLP = enumName prnt
inner (n, e) =
let nConstFLP = enumName n
nBytesIn = bytesName n
in case expSize e of
Nothing ->
[implItem|
pub fn $shadow_alloc_fn(&self, bytes: usize) {
//for i in 0..bytes {
// let offset = self.as_usize() + i;
// //check_expect_pc!(offset, vec![$prntConstFLP]);
//}
} |] : []
Just sz -> if sz == 0 then [] else
[implItem|
pub fn $shadow_alloc_fn(&self) {
//for i in 0..$nBytesIn {
// let offset = self.as_usize() + i;
// //check_expect_pc!(offset, vec![$prntConstFLP]);
//}
} |] : []
in map mkImpl nes
-- Functions pertaining to sequences of named things within a parent
mkSeqFns :: NameID -> [NamedE] -> [RustItem]
mkSeqFns prnt nes = let
init_sequence = initSeqName (map fst nes)
paramNames = map (\i -> "a" ++ show i) [1 .. length nes]
paramTypes = map (const "usize") (map fst nes)
prntEndName = addrEndName prnt
plusE :: [(String, NamedE)] -> Expr Span
plusE [] = [expr| self |]
plusE ((paramName, (fieldName, coreExpr)):ns) =
[expr| ${e| plusE ns |}.plus::<$fieldName>($paramName) |]
newParams = mkSelf : map (uncurry $ mkParam (ByValue Immutable)) (zip paramNames paramTypes)
newRetTy = TupTy (map (mkRustTy . addrName . fst) nes
++ [mkRustTy prntEndName]) fS
newStmts = let
exprs = (map (plusE . reverse) $ tail $ inits $ zip ("a0" : paramNames) ((map (bimap addrName id)) nes))
exprLast = [expr| ${e| last exprs |}.plus::<$prntEndName>(${i| last $ paramNames |}) |]
in [stmts|
let a0 : usize = 0;
let ret = ${e| TupExpr [] (exprs ++ [exprLast]) fS |};
return ret;
|]
-- (FnDecl [Param a] (Maybe (Ty a)) Bool a)
bareFn = case [implItem| pub fn $init_sequence() -> (Int,) { (3,) } |] of
(MethodI a1 a2 a3 a4 a5 (MethodSig c1 c2 c3 (FnDecl params (Just ty) bool spn)) (Block stmts b2 b3) a8) ->
MethodI a1 a2 a3 a4 a5 (MethodSig c1 c2 c3 (FnDecl newParams (Just newRetTy) bool spn)) (Block newStmts b2 b3) a8
_ -> error "Compiler incompatibility with your version of language-rust package."
mSF = [ bareFn ]
in [ RustImpl (addrName prnt) mSF []
]
-- parent name -> [neighbors] -> rust items
mkItems :: NameID -> [Neighbors] -> [RustItem]
mkItems prnt ns =
let !_ = D.traceShowId (prnt, ns)
in ( RustImpl (structName prnt) (concatMap mkNeighborFns ns) []
) : concatMap mkNeighborAddrEndFns ns
mkNeighborAddrEndFns :: Neighbors -> [RustItem]
mkNeighborAddrEndFns ((n1, e1), (n2, e2)) = let
n1EndA = addrEndName n1
toEndN = "to_" ++ firstUpper n1EndA
fromEndN = "from_" ++ firstUpper n1EndA
n2A = addrName n2
mkN2 = snd $ [implItems|
pub fn $toEndN(self) -> $n1EndA { $n1EndA::from_usize(self.as_usize()) }
pub fn $fromEndN(ptr : $n1EndA) -> $n2A { $n2A::from_usize(ptr.as_usize()) }
|]
toN2FnN = "to_" ++ firstUpper n2A
fromN2FnN = "from_" ++ firstUpper n2A
mkN1End = snd $ [implItems|
pub fn $toN2FnN(&self) -> $n2A { $n2A::from_usize(self.as_usize()) }
pub fn $fromN2FnN(ptr : $n2A) -> $n1EndA { $n1EndA::from_usize(ptr.as_usize()) }
|]
in [ RustImpl n1EndA mkN1End []
, RustImpl n2A mkN2 []
]
mkAddrEndDiff :: NameID -> [RustItem]
mkAddrEndDiff n = let
nEndA = addrEndName n
nA = addrName n
in
[ RustImpl nA
(snd [implItems| pub fn size_of(&self, end : $nEndA) -> usize {
debug_assert!(end.as_usize() >= self.as_usize());
end.diff(*self)
} |]) []
]
mkNeighborFns :: Neighbors -> [ImplItem Span]
mkNeighborFns ((n1, e1), (n2, e2)) = let
n1A = addrName n1
n2A = addrName n2
init_after = initAfterName n1 n2
-- | Looks for all (depth = 1) named entities that consume the entire space of the BaseExp
-- (can't dig into ':+' expressions):
findWholeChunks :: BaseExp -> [NameID]
findWholeChunks be = let
fWC (n ::: _) = [n] -- Don't recurse because depth=1
fWC (e1 :+ e2)
| expSize e2 == Just 0 = fWC e1
| expSize e1 == Just 0 = fWC e2
| otherwise = [] -- Doesn't consume the entire space
fWC (_ :# e) = [] -- Doesn't consume the entire space
fWC e = callSub fWC e -- All other recursive cases
in fWC be
poundLeftBumpFn n =
let bump_new_thing = bumpAllocName n
aN = addrName n
in snd $
[implItems| pub fn $bump_new_thing(rhs : $n2A, bytes : usize) -> ($aN, $n2A) {
(rhs.plus(0), rhs.plus(bytes))
}
|]
bump_valid = bumpValidName n1 n2
bumpValid = snd $
[implItems| pub fn $bump_valid(p1 : $n1A, p2 : $n2A) -> bool { p1.lte(p2) } |]
-- Checks that the LHS (e1) was exactly a field containing an array of things, and
-- makes the function that allows you to bump-allocate a new entry in that array
-- past the *current* end of the array.
poundLeftBumpFns = case e1 of
(Exists _ (_ :# e)) -> concatMap poundLeftBumpFn (findWholeChunks e)
_ -> []
-- The right-hand neighbor is null-sized
--emptyRight = case expSize e2 of
-- (Just 0) ->
-- _ -> []
memset_until = memsetUntilName n1 n2
n1Bytes = bytesName n1
memsetRange = case expSize e1 of
Just sz | sz > 0 -> snd [implItems|
pub fn $memset_until(val : u8, base : $n1A) {
base.memset(val, $n1Bytes)
} |]
| otherwise -> []
Nothing -> snd [implItems|
pub fn $memset_until(val : u8, base : $n1A, mx : $n2A) {
debug_assert!(mx.greater(base));
base.memset(val, mx.diff(base))
} |]
initAfterFn = (snd $ case expSize e1 of
Just sz | sz == 0 -> [implItems| pub fn $init_after(p1 : $n1A) -> $n2A { $n2A::from_usize(p1.as_usize()) } |]
| otherwise -> [implItems| pub fn $init_after(p1 : $n1A) -> $n2A { p1.plus($n1Bytes) } |]
Nothing -> [implItems| pub fn $init_after(p1 : $n1A, bytes : usize) -> $n2A { p1.plus(bytes) } |])
in memsetRange ++ poundLeftBumpFns ++ initAfterFn ++ bumpValid
findNeighbors :: BaseExp -> [Neighbors]
findNeighbors be = let
most :: ((BaseExp, BaseExp) -> BaseExp) -> BaseExp -> [NamedE]
most fn = let
most' (n ::: e) = [(n,e)] -- We don't find nested-names (names are boundaries)
most' (e1 :+ e2) = most' (fn (e1,e2))
most' (Attr _ e) = most' e
most' (Prim{}) = []
most' (Con _ e) = most' e
most' (e :@ _) = most' e
most' (e1 :|| e2) = []
most' (Exists _ e) = most' e
most' (_ :# e) = []
in most'
left_most :: BaseExp -> [NamedE]
left_most = most fst
right_most :: BaseExp -> [NamedE]
right_most = most snd
fN :: [NamedE] -> BaseExp -> [NamedE] -> [Neighbors]
fN left (e1 :+ e2) right = fN left e1 (left_most e2) ++ fN (right_most e1) e2 right
fN left (n ::: e) right = (zip left (repeat (n,e))) ++ (zip (repeat (n,e)) right)
fN l (Attr _ e) r = fN l e r
fN l (Prim{}) r = []
fN l (Con _ e) r = fN l e r
fN l (e :@ _) r = fN l e r
fN l (e1 :|| e2) r = fN [] e1 [] ++ fN [] e2 [] -- We throw away neighbors at unions (for simplicity)
fN l (Exists _ e) r = fN l e r
fN l (_ :# e) r = fN [] e [] -- Throw away neighbors at repetitions, because not every instance inside '#' is left-most or right-most
in nub $ fN [] be []
in concat $ concatMap (accum findParent) bes
-- | TODO: Remove allow(dead_code) and allow(unused_imports)
(SourceFile _ headerAttrs headerItems) = [sourceFile|
#![allow(non_camel_case_types)]
#![allow(non_snake_case)]
#![allow(dead_code)]
#![allow(unused_imports)]
#![allow(unused_variables)]
extern crate libc;
extern crate flp_framework;
use std::cmp;
use std::fmt;
use std::mem::size_of as size_of;
use self::libc::size_t as size_t;
pub use self::flp_framework::*;
|]
writeModule :: (Monoid a, Typeable a) => FilePath -> SourceFile a -> IO ()
writeModule outdir sf = do
fd <- openFile outdir WriteMode
writeSourceFile fd sf
hClose fd