{-# 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::(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) { //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) { //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::*; |] -- #[macro_use] -- pub mod address; -- use self::address::*; -- writeSourceFile :: (Monoid a, Typeable a) => Handle -> SourceFile a -> IO () writeModule :: (Monoid a, Typeable a) => FilePath -> SourceFile a -> IO () writeModule outdir sf = do fd <- openFile outdir WriteMode writeSourceFile fd sf hClose fd