You can subscribe to this list here.
2012 |
Jan
|
Feb
|
Mar
(34) |
Apr
(4) |
May
(2) |
Jun
(11) |
Jul
(22) |
Aug
(9) |
Sep
|
Oct
|
Nov
|
Dec
(4) |
---|---|---|---|---|---|---|---|---|---|---|---|---|
2013 |
Jan
(15) |
Feb
(17) |
Mar
(3) |
Apr
|
May
|
Jun
(3) |
Jul
(1) |
Aug
(5) |
Sep
(5) |
Oct
(2) |
Nov
(1) |
Dec
(1) |
2014 |
Jan
|
Feb
(1) |
Mar
(1) |
Apr
|
May
(1) |
Jun
|
Jul
|
Aug
|
Sep
|
Oct
|
Nov
|
Dec
|
2016 |
Jan
|
Feb
|
Mar
|
Apr
|
May
|
Jun
|
Jul
|
Aug
(1) |
Sep
|
Oct
|
Nov
|
Dec
|
From: Akshay S. <ak...@us...> - 2016-08-22 13:45:11
|
This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "matlisp". The branch, master has been updated via 1a015d24ef172b06ffab81007174d2b42416169f (commit) via dd41ced541bba5f641349f5b0477e9c2bf0a1d39 (commit) via 60297cf076073dde534f6197f37800d02c2852b1 (commit) via 037bbdb8d29bdaa0325ad151ad2d48bf25f02e7d (commit) via a48ffc59bab0eff7adbb4ae41e6172b2ccf6466f (commit) via 11a6dd3c1f1aad5d4c322c72df5afee323d3c186 (commit) via e13f6788e1c3e5dea18f37379cc7872cd02e6993 (commit) via 2fb104a8a34598716dca578dea5bf8c581b6a95f (commit) via 385d36667317e84e60a24449423d1d5b6d322318 (commit) via 22622d4a532c0a3ad86f4cb89bc8bee326342d38 (commit) via 0d9e8265c04ff44ba21dde42f2e0268060bac3bf (commit) via d0697d364f8217663d6e1a9837f3625e75bea74b (commit) via 756f0a454ffda9fb32852a5f9b5414b90d584775 (commit) via 7dd41b64f6696a3233ddbd98815a3246093745fe (commit) via 3bb3d1735db06e95c18f74b24780fa3dc7b807ae (commit) via 39621f53b92ec4cd762c003eedcf01e3a299dea3 (commit) via 91b19a64999c616a76a12f7f25684e68f927fd94 (commit) via 3221deee0c077d624cdaa4ef5a0ae0cc8b23983a (commit) via d7a7ee03c110e43ec051ae3a5a8ff91367048a0f (commit) via 2231f734929364e9f71b9a4c9a0066c48f610fa2 (commit) via c4de485d2ebbc54f9808bd73d6e3c789fc308f11 (commit) via fd4d95fc069d4d7cda0e04194ace49f430d4f2b7 (commit) via 6f60038505186e59ce720cd674cd36cc5926e297 (commit) via 3ef36160f9459f7dfd64a4c3d80f7b9f451edf63 (commit) via db49be757294aadb8d9c355ae791f9522a169ebb (commit) via 153293df411cb24f1a2f11da87fa668bcf4860d1 (commit) via c32ddf3fcce4f5be355d584226dfc8739e61d251 (commit) via 94d112d18ec5d94e52352d667782cbe380edaa78 (commit) via 2c170e23cf8ff80f3d8bae90b3c2120d17e6d6ed (commit) via b9698be92acfe4c90a6370888a6611ee6d20d5b6 (commit) via adafff0045c2bc67ed7ec9264262fa741a5273f0 (commit) via ba99e6e35926890048f477e353ac4bdb60245bea (commit) via bfdb87995c51b535fbbfcc4db56bef30515cbe24 (commit) via 0f6930984839e2d31693d6fbf8901591e4105a9d (commit) via 900b84847bf2926c8714f610ba87bc3a2781f084 (commit) via 000299ef6a34c9adfe676e38b5b8dde30c4d4b44 (commit) via 3b27ccd45472a294a10f8d6512de5c2289fcf239 (commit) via c4cf71c34af11ec45f1ce98ac0e9b2485774b345 (commit) via de4e74b379e7faff1dee86eb47c1be734cb62d0c (commit) via c3c4fa773f3542288dea6b497e4b08469752a3da (commit) via 4e01c7eacaa22b0dc2bc9127f49852bec4067217 (commit) via bb560c3a48bd26019e08f5c59ad580098bdf4451 (commit) via 3688e32b8b7c7c17caa02931ad0e1048190859d6 (commit) via 9cd3daee72ee68fbf79df2eddf48d29ddd479e53 (commit) via 55391d559d2ea80ade62545903d1d5a7cdaa875e (commit) via fe6a5a59bf6e70ef44789d0856057ea1d94e41ab (commit) via d9ea3ef2056dceb3faa9b9eb43fe0985c6f21530 (commit) via 005224576331006b64dab5379af217fb0688110b (commit) via 1177c65a3eff38aa103d3b4f4bad7602f8e75deb (commit) via 796484264c893ee470d4ee4831509f0fc5d62cca (commit) via f55fe0bdb0307c450ed8950f72f7373c51a7bc11 (commit) via e33b1d9cb49fef4ce3af6f4d6597a5f49dda59c4 (commit) via d37c421e83fcd843119449d2cc43c37b94283324 (commit) via 6113e9bc25e4c320e80d1abb59dcccedb7242447 (commit) via 284457934c1efe9b1fc39bf148a71276e7dee04d (commit) via 0916dae9c4b60884708a44e6b697e0fb9a71f6e1 (commit) via 2e98ad1cacf396f3379747622272a945d14161e6 (commit) via 08ec60670866ec31ee548c01d2697ddb39aa6341 (commit) via 294acbf65f4594f8b258e07ed5dbd44de5972cbd (commit) via 2f4c4d33fa970d0a8c41f628ae6c9bd720d24b5d (commit) via fc49a3413250a9440c7c2e28809834aa285adfdd (commit) via 37221d8f2c457e3aa0a04247cc50487083499f8c (commit) via ccd5cefe2071bc9850b2d288b0dc368eede10bd8 (commit) via 39290194bfe581c942642b1b13f344d76219f367 (commit) via 6f7d1dcbd9dcaff4d4bc2783701814fdf04fb9f1 (commit) via 0cd54ef4dc1e24e5a0d6066cdca547a157b03dea (commit) via 320023fb642e6b5c788fa1cec33668f6ed4c25fb (commit) via 2d7111d103513c4aad7d2a19bfa653ba99ef6d29 (commit) via 043493c2b399ef34f1689405fce948cf9de0ea87 (commit) via edc6dab27ea493f1c04b93d9eb19e620fc211b50 (commit) via 0c82104ab25bfd10fefd2c1336ec370bde05dbc6 (commit) via 6c5d467a2bd191369109f9c697bb50119c4629bd (commit) via 0683ce1dd665fb77530ce7ec24efcf551a69d69d (commit) via 0a42770366b8c3d8af583fd966b701ebebc9a0d6 (commit) via 6a3ccd16305a9c76f31454a67a29b3c64a6479aa (commit) via 5ee9923c62e123a35b339b2ebc43fd89820fc5a1 (commit) via 2cd91fa63645308b069da9e8ca4a005ef53aaad0 (commit) via 2a4b666d452f93316f2c584f29e7d56df1191a39 (commit) via 443a389e1296d1e87ea9e85ca0f58e2a37ce1f20 (commit) via fa5ee30b90014993f98d2fb1688ee73693863c3b (commit) via 5273e4502a7b13c11e2da2a3f8f5a53fcae4f1b9 (commit) via 96cc6aa5041bc00467c67b90aa966c879117b49c (commit) via 76245cac9d5ee8951050e3c1ba6c26051720ec03 (commit) via ecd17cfeae86e96cea9237d0fa22f3a481d75eeb (commit) via a35c91af917c3d0e1eeeff6737c3b10d3f63eb1f (commit) via acaa9ceef5f04d92cd6cf2f5d7815a0072e1ae16 (commit) via 594f0c358c53910fba1b10a2716305bdfc709b3e (commit) via 107ed92a11b5a993cbc8e95f5c0c25ec1cc48e67 (commit) via 58f22578a66f3470d8868b8877e5280e1bef6379 (commit) via 48066c14b2d291bea184c010c969f43103e624ea (commit) via 61b64c954dd8884e0b021d262a33cb9b791409cb (commit) via 7fa71873e38b71e342d97787151db5bc96ec6d3e (commit) via 0c806f79dbd3ca241c6be47853ce205d1b974b73 (commit) via 11de0a0b701d8526dc1ae5a3fef0e8907e45f208 (commit) via 8798db72d31c8c2c9d5f310d9e164469d93106ad (commit) via 1116c08990840ce8c6c1f7d0beff58a8ef0f71b7 (commit) via bfc0ae5c3f56ea7665f89dd67a8e10e48cd20945 (commit) via 905afe002f11cd01200e52d71c1e0efcb68ca954 (commit) via 202b8cdde09eb7cf3810d3fe094e040d11c6d965 (commit) via 37c0637576ca1f38663ec226344d25268f1fe10b (commit) via 60ed6a506345a01d683f3243a9a702b8eb804572 (commit) via 891e45561adfb019c93188062f7a0f507f98f8e2 (commit) via d726fd31f24e62a100746b7dd16931569e95d75e (commit) via 9430da7fd1f8b4895a83d1cb7ff818b995411b1a (commit) via 983eb7aa008d7de1f14e09fc1e830bdd4dcc22fe (commit) via 97b8d781d7025cbddebea2834e4e8524f304691f (commit) via 66397bad5e776d0fd1c614ce1de6f6e894df7a57 (commit) via 685893613c344882d1255dbe7be7c4c116422921 (commit) via bbc085fd7886151bf02510460e9320da340f854c (commit) via 8ba7e548ba160c6a801279063d0450f4ebf28883 (commit) via 55ccf0f17854050ba1c25d38da5cf3ceb0b57013 (commit) via 6e4e463e00bd4935b20a24fa2aab83a977b1e87e (commit) via c88c6e6a912bfbadffe67d1dbc6a87f500cf154d (commit) via aadb0155c39ca324e4f8dfaa011341a78195ddc6 (commit) via 23dd5bb2ff772a915edef3bb99755b473bc944a2 (commit) via 5c0a2902eb31ca0f1932e68cd143684a16635901 (commit) via 469e771842324921018f42b75643c0a2fe4a5f48 (commit) via 94b65e68f2de5208ef9641cd105e25512c36a7f5 (commit) via cae6f148445aab178423d44709f3698c433c1e17 (commit) via 9546fee5ad2b7b4824820ef9c8bf50f5287fa6a4 (commit) via 81566a00b8a0e1340a78a79ce5705e7361d0ae85 (commit) via 9aaf4871f793170dbf62a4631da9d315816aa643 (commit) via 1dfa4dec625398d4295d7836c3be5e68aa12cfe7 (commit) via 1bf9c9b21018655ecaf50b7e2185ceb527768ee6 (commit) via 1be4accee89b2328c4eb005fdd5b5c726ec28e0b (commit) via 9c9c27182d3c86e7bee9ce17bcca33d5438d3e93 (commit) via fbf3d152a99d2e70cc2a359dd3a44055ac5d6df8 (commit) via 2f7bff9572c460718770ec23821616410b63030b (commit) via d2a2ab1af848f393abbe0775245a98faf9121c9e (commit) via 79b2580d7558687ef1b54caea105164cb03e7dd8 (commit) via 23942e5a3417964fa8da42bde635b92870961aa4 (commit) via 4eed6367caf3871507dcf10df396f5131165648b (commit) via 35c2bb5b71f5e50cd1fb5a18d1d2cb2c7b456d02 (commit) via a26f789808a5cef1b6225b0dfa99266ad4c244ac (commit) via 189e440f0539dfe7b61ab01be288ef21ce1a293d (commit) via 0d61e7c9fcaeed1cb863535befc8aea8708db4e8 (commit) via bf1692583a74e0b1d162faaa1721fad13e2a6add (commit) via 38cf1e1f22a0bd1e8d91253b1a157532762e7619 (commit) via 471131427d364372ed3036db61a8c07aaadd52f3 (commit) via 94f46323ff143339c259d7df763c472d65ec708c (commit) via 7020a1fe1e5fe187a946251fd8d9a165d594b006 (commit) via 9fa86d9d126ddefe940be5bcb312f1d5bc2abd56 (commit) via 87f94b06643502a559c5cbd7846c3003afa26166 (commit) via a6ea51668e827770c7d5e4f9a17d25239a9cb16d (commit) via 2f285b1ebd72f0a3b67740784f5fd9356d9860b9 (commit) via f390613050a75cac7d68b1ffa700102adb536334 (commit) via 6c53261938e91442fc8c8bfce60d60fcd357ef85 (commit) via 8fcd27ca3346420fa26e7313d305a5476e518f3f (commit) via 293ea8d4971cac70b3e15b98da0db790b65bb5cf (commit) via adb2964e272be78baae796f3720cd8625a28c905 (commit) via d0d1f3440a3f748f095837c5c23c71af3ca7ade5 (commit) via 38cda2383fb318c296a1c14a98c199f035015338 (commit) via ee44b3328c471ac1fcea28c1cb3a549f8fec6a67 (commit) via 876a22424a2428c269424f021e324ba9f1f066bc (commit) via 0b15cd1d3306b25849e0d24286f678813c7a823f (commit) via 57c51122f65377f9e95e5968d300955763d2330e (commit) via 3b2e1cdc159bfdc212083e785cc75cc4ba898b3a (commit) via 4ee34e5fa43590ea3c30890b1dd9e25ef61dd15d (commit) via b07d86a2949223ea41874db5312ad466d9210697 (commit) via 973b4a406cab55b0334c21dc5a1fff1878751270 (commit) via 46c8d439f2fa053f1d10f24cfc5d92ce4e3dd5c8 (commit) via e513479ed4db28cb8a5e388ef959aef2d494480a (commit) via be2c98237b039c2520bef8407c01c8cfcc4da966 (commit) via 5b6d8073843fecd6e1e9fdd7da48fd6664dea780 (commit) via e21a2a3d0528db46c2157b998ea7447788adf551 (commit) via d12c7b7de963a381ab6cf7fa16eab3e1b638bf49 (commit) via c081e8620ceb0791649db69bff4996bbb2d0b1aa (commit) via e9787f5d1e79170e087fcb4d73677654e1406939 (commit) via 2264eaac944bf3f0ab4afff2e68330ea97a400fd (commit) via c6d24936452cdbcc93ccd0d291265b8c42b32f13 (commit) via 835ab7165ae03dd3b2f729be06fae109f510d541 (commit) via f4ce04ca7d1a9d8abdbfac4cc9e07fb7c89b40ca (commit) via 7991ce84cf185d777714fe02b3b7acc441ee0b9c (commit) via 079ea856dba23691bde5bb3549258bb038735658 (commit) via 3a24e0b5f777768bd173a94de643e0bbbe7e8060 (commit) via ef52a4f044bcacaa9e9ed3ceaaa32757e08336f6 (commit) via 73c1278b64c685b3c99e9bceee8820db7350fcad (commit) via 0ce58792bda8ee5ceda838f6f5bb8ecca19b0425 (commit) via add144959b0bd9a72bdc37379e73ba3aa407091d (commit) via 028868267f4b3afe0b9078703978852dcb5a5ee7 (commit) via d2485564d605c24ece09ea6a8242bec31dff64d4 (commit) via e798716024cd892be2288ce16c894b6a6e4b4268 (commit) via 213c32b68dbd238f81dfa467f7eb4abe39896c91 (commit) via 5cf97eb23903e60eaf76982f63ae259c20016112 (commit) via e2990705d49fd13bc9e3907e7f50058877656ef9 (commit) via fe8ca0d1bfa7786fb8ce402b373c68a12282fd60 (commit) via 29b9b34ffc470289530bc4c3ea50ae83e0f87c10 (commit) via a193be3a51f0c1c5e9e37d47fc166139eeed965a (commit) via 131aa57f9a4ef6d9a1efdd9c7160467ce111943d (commit) via e389009a5953e82529b7c82b51788a2943f2ce52 (commit) via 9027e5427a552c7256562545b3abe947362975a9 (commit) via 2010f94ec414515deaef6b4e386220d3b52a45f7 (commit) via fb96f5b3d82ceef3c26ba90f1d7a1297c9f43b84 (commit) via b302d3e6103136fad0fd7abde2cb27123303eae5 (commit) via cf5ce32c3538fc032452f1e30a7e9cea67ad273d (commit) via a250bd28d0fe54e71f3fa21a9564f14d11c5fc84 (commit) via 58a1f8f184689da421e0cccad11b7b894eb32a83 (commit) via a7af1ec8d7998af8a261be4d3b883331d93b946b (commit) via 60218d0bcbe95ffdf5cf2e37475d8a6353845b58 (commit) via 5735d73a9c69210a88fbcbd8d6129eb2074b3ab5 (commit) via c112774f9439b0227a510671670b453bb521f8c4 (commit) via cc7e9ca7a94ef1472e4f5ab2eece80d4190a9f47 (commit) via 2d4fd8ef10a18cdde811f279682ffb247f095375 (commit) via f86b0007f10e74ab382f51607f97449b66b1fd44 (commit) via 2c2a445d273472d215e3ebcf38afb3a00b5c0e20 (commit) via 7717d62625682111852b283cc242b79de1296a1b (commit) via d42cb3ca26888f5d78fa04085fd24c033512267b (commit) via a58f12baf0d0953decbc93e1f0a2ea5f79c70ef9 (commit) via 861c48927ea49efba2d03e749e5f40ca57bfaa18 (commit) via b847b3514b2e48492aa2c19fa04142968b7eb6c5 (commit) via 521a462121b390474f13009a66af311f3bd8dcc0 (commit) via 4721a58c0795326661799eb8d109c3940feb5f3f (commit) via b0e1a0c992503c28631a44b79ec7e3994f22dc1a (commit) via e5d40878ec1b3c2ec0b5b0c593d5c78cdfbef9e7 (commit) via 2f3f0035eaa8823465da3a459a0ede0b749ea02d (commit) via b61bda16cd9dfd60434a9eef6bfdc13c29716fe6 (commit) via 496adac9889142ff8c43079fe29307b191c9b1e7 (commit) via ad177bd791e2059c229e1fab1283ee23a7da79a1 (commit) via ec2384323354de0079d3213f8f49e83edcdc680d (commit) via 6e0b16af44ce35a6b850040198ffe1dee7764e94 (commit) via 33975a1a0ebf1414cbe4f69ae49789660b42df74 (commit) via bbffed2a1663d04da020e1fb282c280aadcbd61c (commit) via 4044ba135c0cf36ed8bc9709ed4c2aa1d71e61c8 (commit) via 9624b4a7f3c0c4ca512eb0c0cbf99b9c81b1fc5f (commit) via a4fb36213dd45707c0693489b5c0d704f00f523d (commit) via 68bb590734691ce2e37ab3b5fb420b8f63635fb7 (commit) via 6a10ff471532a380ceaa5ebd9ddce1afe9985810 (commit) via cb0798eded5988c2e62afdbc153c61c99c7f5418 (commit) via 6703e936375147ecb63fedfa60257027c9cb0a0c (commit) via 3361b48bd53aa2a9cbec2d64a23039c2668fd0f6 (commit) via 1ddfdba533982b362cab9061c1bb34bfb701f707 (commit) via 651b4dbd31fe54e965f4d747a22e2c2467130ff8 (commit) via 7ad30095ead69f5b4b7a8f5f3b51fe4fbd26dcb4 (commit) via cd8367fbe11b2984c68ec08888c0743e7e3898b6 (commit) via 709eaf589d3cdd72406406832723ebe126d71888 (commit) via 873cd5ae0e181576d7ae8a2fb307e5b9cb5a9a59 (commit) via 24593618439146ac7d6da201c504f0e01c296b80 (commit) via 95c9eefcd363fa2ba05e92e3322758c81219e6c7 (commit) via 3a21379dbbad3665c85a95128f34672b96ae1851 (commit) via 5b7710825010f450b71da9d0cbfb27411a86994e (commit) via a596730f7a5d3c3d65335ce032e8ffc3df557837 (commit) via 8b18fb736d6bae9c0fd16a0faa51efed07afb294 (commit) via f4e59e53ce5f2de3462c3c554f6bd075b3f30b6b (commit) via 6d0ed7f102650f8c775144d91c7e38901fa51ff9 (commit) via b668733e8899254c129a7b1d109b4a229aa95246 (commit) via c81e3b9bbaf654e5d5cf4b9082d013b6e0b9b1d4 (commit) via 8e9e139ab7884f3811834aba6c9eb5d25c1c79e3 (commit) via 56b707f789c453e157d0818fc8fcf0a16a699db8 (commit) via 3caa822f9516b69bc5aba4bd2cb840a05b09e48b (commit) via 3afe61642a8951b86133c79e1fbd19839f48b8b8 (commit) via 0d327c3a710ab3bce416b0ac48093557e073e6b4 (commit) via f907ad7cfb43867bce9af5226162e4d9509d9a00 (commit) via abb0a6f58d54ca9629afef9e56afbc41041ebb14 (commit) via bd8ba7b1d0ba2971f28a1690fdea106397a90d04 (commit) via e4f79071c3818c46ee389c04e01cc086497966e9 (commit) via 5e67db6057fd19bc32ff2391f2e2a1aa278448b5 (commit) via a81b698f2e9335043ee0415bbb2cf5e8539c66e8 (commit) via 6747a6d64abbad33df475d238be0be94a616df9d (commit) via adf629e94fee94dd32c4741ecec91c7567a6049a (commit) via f527df432b77c0cd1d129ac04c2ef388a6521622 (commit) via 165d6ea255110612466567fab0f1d6b7352f0f65 (commit) via e8da7463cc4af5a1ebb34f4f583e3fdf4612fcfa (commit) via 9cb26abe19d52ce5bb7fc1873a6870ebde9954a7 (commit) via 536427a4451d57ba660ed0dd09771ddcfc1b84ad (commit) via a195dc65fdc34de0b32109511a06059f2eefa701 (commit) via e9f2199b996e73e9e5f3a4836d28100bddb5dd04 (commit) via 72f1265aef1909ad6ae4ba8221a1b13374fd0036 (commit) via 312979c7214c49f9c0a2ffd29a27557be73ea104 (commit) via a1b8de0759bc21deecec1b44462dbb022f30c768 (commit) via 313c41e3170fff67f8495ddac3fc084d0dbbeb92 (commit) via 2a305a1aabb5d33c5c1967e257d3802d66e2c0fc (commit) via 59cc9209020a6f3f22a04760a7af7292b8959526 (commit) via 25502e745746d57cb0255579aad4c3fad9cbb206 (commit) via e7b1e34c36d42dd0a7d651b3ec3f4dee514dd44b (commit) via e5d57952737b7558a81583609ae97dbd77b9b557 (commit) via 6e9a51f360bdf55d86c0c905e836daeaa98f7bc3 (commit) via 5f6a1194181a0702e3f8a67f401ef34eb8863c36 (commit) via 0fad8e8adfab324824eb5be7bda579ed366f0a89 (commit) via fb6d6c916959ee249a6d1e4726019307bdb29f0a (commit) via 144f7817e8eb11597f795a76dbda9c6371b61c0b (commit) via b301eaf23d1815d9d1521ceebf0d669e98f3170a (commit) via f98c528e0f88148fe96c5c34cd085a0281bdd9fa (commit) via 5b3e1bbdcd79e00b2dcd251d85dcd42f7e333cdd (commit) via a6b74d7ce09d42adeeab287b8a4cce1fd47c58cb (commit) via 24b661d49484fd9774bebf80c07c6dc836f69779 (commit) via 731e677c5e9d7eb73033fbcbb78be1ab2987d5b0 (commit) via c14d06055ad9164df1e9fe34ea2d285722134772 (commit) via e17ae2b44b5956cb4a4ec3339273f1e208f501ae (commit) via 1560a36faab44c6f9d293c57693045ebd21ca96b (commit) via 5461bd2ef8e0e6b06b3977117de61d13d531600d (commit) via 8198d66eaf11fef2717f452c4c41da00a2e1b429 (commit) via 33d2c5fd06d3e60aead58431e268a2e42d7ea367 (commit) via 9dc526079f9cc2b5a9e5c57d7c4b54236a385263 (commit) via 6a5d74a7599f4ca6a8afcfaadfdc7b0c3c237bbd (commit) via 7d21471d9da7de10e6a830dc0259efc17e8aa840 (commit) via 3c4398cc36783ea7a321fbdc331b1160c35bebb4 (commit) via 00de47b9b5cb595a23b37e2d98d2f2fdeb92dcba (commit) via dd1f88674eb90b3af6743dae3cb48fcbf73b9a9a (commit) via b34c2cbf5974f6f7f5c20dbb86a424cdcd88fd50 (commit) via b3efc3a5938126c1010dec87d2a9d8b35d42b5ec (commit) via c4f19e17ff8eaa53b4dc52ad6054fa0611700a66 (commit) via 6833afe74673a047fa5916c95d91b76a1e449028 (commit) via 0a01c0e5591324a538b86cbe8405e7a7f6639034 (commit) via 5b70afc8934b8ca3116fd79b78eaa2a244f8d60c (commit) via d085bd096912a652b2a620821669f7dea5b5649e (commit) via 8df18050e19d4de26f326c870454f46af872de12 (commit) via cb63f4927ad9d371a675ddc995df9119bc7afc17 (commit) via 9621836c207ba1fe67ef27eb0f5f1d4b7287d849 (commit) via 6cfc62a0b8737f16a23c7c971cd5055fefb42750 (commit) via f3b37d1e92b7ee9cf9b508bd98df20df304bb958 (commit) via f235ae0cca3dc81ef9fabf2a35681ffed8505c79 (commit) via f82f9f87566e7359d0ad758dc61dc070cb29a3b0 (commit) via 03a936712182f839eec89db4ba08f0708af98dca (commit) via 6b070ed0049cd5271379c18e7a08e6f222d3b015 (commit) via 749437c8bb376d094b604c6977a7e7c037a522a0 (commit) via 8aebe561eef23310bcbb1cb2f93518a68f454231 (commit) via 9a4472e4325ca93c9bdbddfedf28de9ee724b6cc (commit) via ae2c399227295cf632250d8ba6b0ddeb984d0cae (commit) via 1f0deb99d702dee0b93e3defe2404b307c7b3530 (commit) via f38e6dde50fbe1552793f8146fa42734d522e9c9 (commit) via 4ae0303bba3df2d7d9b3470181947a0056d72e1b (commit) via 2222db6683c9dbf031cd4db8db5214efe60b6d66 (commit) via 6c30013f4baa53a1b9fba64854c5c1e5cae44809 (commit) via c248fe3323b34374070cb9df9a6d765a85e73b01 (commit) via 17a8a5233aa62740a17e8049835976f7a18e3d26 (commit) via 2e87492c26e3e9f0705efda698f6183d9c1425ea (commit) via 4d63cc7ebed68cf20b1b4e83cbfb6b8815706a4e (commit) via b6f729d172193ff03cf1ba88d1deb1c7634ee11f (commit) via 1c59134bdfcda89a91ce78f8d69836fd3a2628ec (commit) via 7cd35fab7aa468327b733ab1d5037a5e98c55e08 (commit) via e51ecd915cbd2a9222b653d70bda556411616999 (commit) via 983fa49410b5ff5805ef9f63776884fc72015f49 (commit) via 673b1af27a8d2ef318dc02b9b73aa9ce2f758fcc (commit) via ad1dd99286b8c8f0ec1323aaca6911f7f3fd4c99 (commit) via 8a5ade0a47e01bd93e19f72fcfe9691ed00f71cf (commit) via 57618ec426afa04b6553dec19c4c96971c98f5ad (commit) via 7ddfe787e54e485108ff96839495e7a6f0d490c2 (commit) via 5cb54c25cb3aa489df3cfa6065f537d72d57cf19 (commit) via cf2de4f3c12aeb90062dd7afd82120aa3e5647a7 (commit) via 270890c43c5cfc819b9d551dcfe50167976af0e2 (commit) via fbb6af74f62783e94dd623de0bb6a50d3a9325c4 (commit) via ecbb04d8adfe7d75a4f6d064fcb0f14a66613556 (commit) via c0248c645d3d100b8f2e4b6569b730cd29e7589b (commit) via 32bce0a5847fc2b5ee46698b2e6e0a3a63466d4d (commit) via 24fca164d6b861365bdc977de64a29e6107da555 (commit) via 6dacaaaa8356ad476ac631eb95b93829a5f1e3f1 (commit) via 03fc1d7dafa1157eea84f9df3f0a24f1b4b240cd (commit) via 1d27fd93c94b99ff3f6fda26106e50c4d4cf1b01 (commit) via 23f3205a3cad2be9a270bd0dc4acb57d42d8dbb2 (commit) via 376d74de0a77839136869bcc27c5f877cb4a3bc8 (commit) via 953ce0f60f25157a4fc5b5d31403433aeb47e894 (commit) via 1f45e5ca07fb6ec6e83117fdb4a3ded5fa3e2b4f (commit) via e357e8266b9d8c1590fff4177057582577277846 (commit) via 98719db2d568c5b022b93d2520db95e89f210d77 (commit) via 705275944ef0cbd6caad409f5a3b3148641fca32 (commit) via 767a08754c5f93918b9bba5e3503f0286191f179 (commit) via 2b4808f24ea2cb5413b5af069f044a2f1ac1eef2 (commit) via 66de9b29137420f14bf37f794dbec1129664676f (commit) via 5481334c9a288f9ced6967f1995d4d30d0e39e2f (commit) via 6f9bed41c2556366ed4f8bc79516e8c3c3a19ee0 (commit) via 5304b7204035eab0b7ac2664a6e1949a0689e741 (commit) via d112fcce019bbf7c536a4047927cfa248bff6239 (commit) via 54c32278dd5b119ca1157b022ebe1a1b0f945f8e (commit) via 06961b98935b57db5dd4d9b56bdd93c647ba6484 (commit) via 22f5a0bcf4a70d769e8448e05840fc9ce8fe7988 (commit) via e2cf244082f3b9993eb6d9e4f6051349f80ccbbd (commit) via cd98eb7ed25c777623ccbacac627bb4968574536 (commit) via 2247ca7cc973977e061ee894efee10faec823f1d (commit) via e41ab636a047d01b438e86d24ad4b5169d0edfe2 (commit) via f8b87a620796e228cadb86996b85f4298409ed75 (commit) via d5f56f654435a06be255e30e2f660360e6920ced (commit) via 739477d2ea4ae8e582b2355220d502443cd722a3 (commit) via c6c440e0043ee6633cb729a0bc590e9ca97d5eff (commit) via 6fb6102eb0a39b2bf48ba2dfbe98f2d7a1966935 (commit) via 60f2b8490d5a31c90886c51d081bdb802f5431d6 (commit) via 050548a939e93208a4990b6de248e3e39b3caa45 (commit) via 7aa696273c37819ebc5b9ee1040d0f194dd8145a (commit) via 570ae7eb80324580ee27cfa7ba1d20b11f779e41 (commit) via 79a87b8605dba8ae97c8f354e42f1f081b127771 (commit) via fc524fd099c95abfc3af0280e8a200e461cc9493 (commit) via a3ea5898fd82c16b66bf0ce3d5615e370deb40a8 (commit) via 69ca54a98c4e4a03e004268297644094b5541cae (commit) via 6c6f96e88fab82f42a2cd563c53e90c48eb8da24 (commit) via 1f3bc86e39b2b9d1a23946434486a99faf9d7eaf (commit) via fd0546544cd3c21641688e03ff221b031ac01ae4 (commit) via 62f126ef664982e0c8ffd132ade8bb5308833f56 (commit) via 9afd000d1a6b497e3bf4fdc0318884b412773de7 (commit) via a7bad8cec909a69bb312917406d3dfc1626f8c12 (commit) via 831a7c79908907c3702b623d0eae3a0a1f746a58 (commit) via 05cd941088d8c303f3b5f81d34a6fb336f1033a9 (commit) via f051c33ed570af222cff1fbf93802dc8844034ad (commit) via f314da645424005358b1921156218063d8ea64c2 (commit) via f47066fa8877ca56d4d58f36a5a08515593b8a2f (commit) via 1894d2f6b21c756ec5bb2ddd443e6d38a7087f2b (commit) via 808353d428ddc07d365bf1de8abcc86f0179ee08 (commit) via f9bf6a61b1860942b520069596563b2db546f927 (commit) via be4148122456b5f7a6d4032fcba44e4652f4eb0b (commit) via 228188fe426f884dd6a1743578e879350b7050ec (commit) via 03eedb3f3faa199ef9b76c30b95d4222d98dd9be (commit) via 7e8e80cf438552059d8d05797da5a4f9320127d3 (commit) via 222aee503ad0678516eaae1e638b016fb01efb09 (commit) via 5f237cd125d3d50ae322fdeaf1db314f0562830e (commit) via 95d41cef90f67e4d0b50ca7679ce5b5bffdd7532 (commit) via 8273423d3f82d599972086c6263975bfebe6c3a2 (commit) via d7210a4b81356e32907afde8bcd13d4cbf97dd00 (commit) via 1407d41f3f3150a905e8cf33e07db5042651f8ae (commit) via 4248b0bfbfb4fda8e99fee6edad8383f2afcf606 (commit) via ecbc68d2926eb4dc1299401beb741e3551a3941d (commit) via 50fcc688d2f72e751722b74e994808ad90f4c1ce (commit) via c108b24c014b002d9d0465ed895a8223a766230a (commit) via 0b071d4d11400da962b99cbff50ee42afc443b0b (commit) via ca0287f4334829367de787ba0e20947f53b6298c (commit) via 24def88c5b5227b29154cee9e05d88d119ceade8 (commit) via ba36a2d0877b66fc5b6b4055b9310b2e60a54186 (commit) via ea151122023fbd5d481a831645292fa3232b7b8b (commit) via 23ed3d8de617ebe9a31a9df73e0b5c379de1340e (commit) via e6de232ea94a34325a971da0355eecf472c7769c (commit) via f3d0633327f4ceba538ccb2657552b6069850bfe (commit) via 9f01a9f4f148c9a00ad80d5eacffd667db2cbbb7 (commit) via 83545ebc9021cad75969d41c803f5a4557c61e9a (commit) via 8d1294ce927280b8f2633b1e8636bd8aacfbf45d (commit) via 36eb4f85eaf7042a8f2bcf7a1af1f48dddd7bb45 (commit) via 6d64374a148b18ceea55608f39b0bc0d5f8cca75 (commit) via 7338eb40c61c8fcab6a6180f68c0db7e013ad9ee (commit) via 039adc9fd4f65be5beea4d7f077a54892c3310ca (commit) via f01e8cb0e33110ab72e6e828f052e7c534c84ebc (commit) via 18563e60200ee394dc974dd81ec63a48e2b96ea5 (commit) via 2bf1a9674740ca3829a86c45f0dc14a2ee3157c4 (commit) via 9253264f16cb969a88e0411ba4e8441a18406395 (commit) via b8b3f1fdeb9425c9e36e096428fc04e044f720f6 (commit) via 8c2e30aafd1d5481e28d62cbf5382687fe0b4fe7 (commit) via bff689247f6e345a4ff7505a2973d70a3e30acea (commit) via d5850b327492c870f2fba052f997dd9cea2a488f (commit) via 926c7dc0991dbe277f1802ab9074b89599cc5008 (commit) via 2f7115f30d58288fdc9b160ce621ab19d1277772 (commit) via 468ad7e97a5c82ae3ed1c39d47085811b719e8b0 (commit) via d43798f53f1a103b043af6fa6742ea347c777a2f (commit) via 7a8ab5c0db938424bfc8d2ebca6022e2673b6a9a (commit) via 28177ada352e525b622e38a5c7baf97986854288 (commit) via 702e41559e7f9cc9d84d108e467a1ec132e6f50f (commit) via 13671606829449440d65e08dd7ec8b54560c8f23 (commit) via 10d713510529c4cc86dee7c000eb400b6ae81b06 (commit) via b0e4abdd67877cc2e4a2880542028d0d15c8b3eb (commit) via bee3634bf96916ccb63248bd8fa61c16d7c25da3 (commit) via 0c9fe59c75989013c9154326a382abd22fc056f0 (commit) via 23ae23fc820468a4dc5149850f7f85bd524ebd69 (commit) via d7359f74d27661c0f8674d139ff196325426e828 (commit) via dca1995e47f24342e2a8f12fdcbd4b667b76a67e (commit) via 7dc82f982eff648874c67454a6f6e5a947104f3d (commit) via 8230a46f93849cdb60ce09173ab31687f998d07d (commit) via a9eca9b0cc4287b81b325360972175771d7f6c71 (commit) via 4862a338530bb1b435f2d6535913abe9947931b6 (commit) via 657120d7a8bc0b0e26bbb522697e75c9f5b92ec1 (commit) via c8fdfac6f7cd8e4dd91f49bf7794a579cb8a5ffc (commit) via fb2502032f279c0981185f2380ae3e4abf9d04a7 (commit) via d2af31a71301c518dd6a732ec6a29ef91f6e43d9 (commit) via 197de2aae64171ec7f71931c5c86f2d3091702ed (commit) via 5eca5ef812f5ffcd17a203dda23e55d16b0da822 (commit) via a5e3a50f5fbe85eb2b44d11ff2a6ba385011e979 (commit) via 32fd23120cff0e68ba1b02290f19e0dd48185944 (commit) via 2595c1c4e1a710d38b0c56c83921206d2473e8ae (commit) via e916823ab6bd97795ad7eaea63ad778a423b0919 (commit) via 856c60140465482aaa72f021360c4c795073ad6f (commit) via 0166ce8014b662aca4a91484eb2458e7e87be8ac (commit) via 1c74913ff22ddc869220e6ee124bcf272b188d12 (commit) via 376399e23fbbb868c8eb3ef80ee8bc9c65c5d98e (commit) via ff3082257b6f984b30131dd170f011eacd78f7e6 (commit) via c0ba7e46b390f6e744e6865192b6eb57eb95c585 (commit) via 4c6e88337126ac9344c8735b98f54aaa69daa99e (commit) via 375d3a119c4645b92fcc78767c0dba0a97c7450b (commit) via 4f3bb155a516c02c49dd085b37283ca431f4d24b (commit) via b68ae3c41607d5c2efb16bb20e0b5398183bc0a1 (commit) via 5a902f797e8dfef15f1d8d048c5f9ad156f1c192 (commit) via 529111481665902bb1459b434d8d6607c2467ca4 (commit) via 8fb9110abc5dac35858285c1b10a1cddc2e35024 (commit) via 938bc521fe3431d9a4cbcc0c7bab9c4bb616aaf4 (commit) via 9b50685d6952b3be9ff29473595b2694ea234b08 (commit) via 0b4fcdfe7d12f45c1d46f3b42589a5f2ff54e8dc (commit) via 7424dca3c956b58d494e938ed7acf90abc79d086 (commit) via ccfaa98ec85543e56211e9781267becf93ac4b9e (commit) via 8740b36ec8cfd52498f7a47d96eb0d65277e5b7a (commit) via 8bd622f7d1ff8f64cc977e17a35e8e6bc29183a8 (commit) via 3fbeec55d702bde591b5d06abe6dbe2334d4735d (commit) via f27e7165a4d1127a21c7cdb9148b986d92b401d7 (commit) via 381148cb7fe30e07d45ce8a49d87be081ba795ab (commit) via b9bf26aaa85df12dec80c1c5b822d8821ed6e9df (commit) via fbb318b4ac5ed7192722ad350298173c4d391a6b (commit) via 5649455cf8b1d1c0f073d52bda626d393dab67c3 (commit) via a640a37462d29cefa33c54e9e08c89ded77f29d3 (commit) via 05cac9e6e247823c2fc6f058da9b3904983e1edb (commit) via a4355472b2268ce43bafae38350d0e76f186c953 (commit) via a922933e28c83cbbc1bf9a2dc7ae3341b76fb2cc (commit) via 8ccded8d5db3d1918b7af875f4dbddd16dc75f28 (commit) via 284a1e7bcb18ff7bc25e53d2b636d4fe5c963205 (commit) via 855c687f17ce0468bd189e8c6f9942ad5cec2999 (commit) via 9a94775cd4eb5593fea88f5cf665bcadc198fb6f (commit) via cd30ca81e687388cf532e30e08f79b68cf56c325 (commit) via 3d2b1c49901f857eff0b30ebecaeb251d35e1755 (commit) via aa67585771f77454b95fa7b16767ef3a6ff03923 (commit) via 00e53dd09b3cc988dcd4e6e82934ff78bcb83501 (commit) via 1ab6cec8e17077b9533560c9a5bc010e95818a04 (commit) via b6be337cd4bfc4e869cc13317e36244517fb95a8 (commit) via 4022a66033df8820d07bb2abd81b9a355274bd71 (commit) via 77cde81e39386e147ac35c488d1f7c581d7bd9b8 (commit) via c73c3a034c2a655afb2edd38ed6f0dcef6050b3d (commit) via c2b5936d4d517cf0a7ee3e8d4a5d9b683249076c (commit) via d18665bf3b836e17d2ff75065b384b5ff07059e3 (commit) via 2b87e86f1392efee853a1807d7c9299fee1f7958 (commit) via 04ac7f795b17225ad7f942b85bad9508a885ee1e (commit) via cbb7c2bfaa2dedc65e56be04c1469e46be975801 (commit) via 63d6b10a662cb7b8ad0b3dfd288db7a5f921abff (commit) via c30fe6989eac02b31688733a8268ba0f4cc04891 (commit) via 83d461878939dc99bbe82269d113041fdbdc9e52 (commit) via 6770dbf44302c7d981ea50386827106748b8f3cc (commit) via 38da10cc73eaa514e7bcacc1f996eeefda503078 (commit) via cfd1ff7fa12112dcb0df038f9ecd60a5d637aa18 (commit) via 6876d4167f165dbd6b9326251171d94020c99d64 (commit) via 5b9abacfd46513064abdbc7f8ebe75c23d66b030 (commit) via 1acff5176bfbef93576185057fe527cc70b9bb5a (commit) via 9c1d88d3e0101d6764260ba190f852435335a5e2 (commit) via e09abd6390492ec30a362f91a286558388cd7bec (commit) via 9bb4a65ad72358711bb82ff45cded5462e739def (commit) via e1fc53ef3b80bbe7de9d2cd8177f465e20d78fe5 (commit) via 2ea68617e269a162c2e722fe7b3314bec1c49a60 (commit) via 391e3cfc964a8038324bcbe654d45c763082986d (commit) via e3a4c5986e5e511c7ffbb1db7a96555bb24f31b7 (commit) via d5182e428a4c3a261f307a55f3f4bee5b23791d6 (commit) via 8bd064bd60e799c45ed248e17ea9dac42960a631 (commit) via 71aca48b041b5be2cd4c6ab8d514b260bdc02b19 (commit) via 174d27300595c21a466a330fa34ab66fa7131bdf (commit) via f25a68740987eeac4539d48b7a58d189da5b28e7 (commit) via 536e528120dcf8631dbb9a8d4efd9af5541e55e0 (commit) via d5f7ad309ca59d41c6e405c512f9a3544be01ea2 (commit) via a005336f729ed3ce87bb327a6fa6441612fa20f9 (commit) via d8e8b94a89920c6c741031b0a525fec2c62a9d2d (commit) via 3727a088ffe014773472fd37a7d45346917a73a0 (commit) via 695636685fd91ce1602b135d0c0e782ca06d47e7 (commit) via adf78b01d61996d75fda7ce045e3f3f11aa3f9ed (commit) via 1231d97cfa4e89109805a7a5284d939bbd65f5f9 (commit) via 848eaaca232c394753e19a057fa732c9937a8a39 (commit) via 8aff3fd16623c50df552430e3734fc65d11a55b1 (commit) via 8df10fb5dce5cc4da3e196d0ae94494857a53f50 (commit) via 82125cbf389c2f1bc43a5c661067400efcec64c3 (commit) via 578dc43e356575b8c860f46f157c07d773843af8 (commit) via 0f1b57f2c90f00aac4aa5ea6e7240ae69690409f (commit) via 8bb55ab5b53aa70785619511fcd6457b3bb79401 (commit) via 8232b005b14d4aced35d7ce07afe9a9c35233b7e (commit) via 90e484c4fa59934da70010e4b2ff789fdbf6f40b (commit) via 1d9d45b7aac05a33ccb3cae5428a08cda19d00ce (commit) via b7491a45a621cf8b4d5c266ec39a8850172d2f02 (commit) via f9871bd640672b300b2b1790671f16694a67c184 (commit) via a1fba66076d96b9abe83d35ac2780be0fc363e1c (commit) via d19ddc6fed6d674cc555e2911c3a8a44334a0c20 (commit) via 365629a9b8ca20f729635ec74047904caca9c8d9 (commit) via 20c39c7a913544c3f542fd338568aec439fbd838 (commit) via b69c4cba35a5d7644c60cdc8b830f60bea9f4b1e (commit) via 21d8ce7bad4335a01727786b8114af348c31d3c9 (commit) via 45e57ae1f888c8c271a91d42b9231b99bd55691e (commit) via d54f0adc84bb64c23dbbc4bbb1c7885e8cd610e6 (commit) via 4010f091a89e7b2b0a606cdc3251124b609699c3 (commit) via db5331565aae1b08109f11abba655999d3774c6e (commit) via 7fa7c24b0d56039a1fef930ffe2051b74c11ebeb (commit) via 8191e3e96c966fc09587e44f98a09e42cd5985e9 (commit) via b53c930a62d5eadcb565e1c77b13a33ac3f24297 (commit) via 7f20064540e1c4bbb9ba535c37fb1533831cb217 (commit) via ff263186ffc1a8443f5733cc975ba2e7c66d2206 (commit) via f53e544eff8af4aa8fdd302a1adc98fed1b5aa35 (commit) via 9bfeec0a8b2e5604b2ce6b7ad6be62c3fd3f09c4 (commit) via fd41f88aefad9d87a8c9183f946ac14c3b564de8 (commit) via eee93ce6980e4a07c4f7d3ccb4604666691c529d (commit) via 83c3111d290cc5994b05dcc32e2ee51cb1529f1a (commit) via 7018af71d307ae84ad75a29a79d61db33d981430 (commit) via 514db2b95e68cd882d51d9a6d603fc24b6f0b2bb (commit) via 41f86e07e1ab87c390f9e570bd51ce57ac2d4d6f (commit) via f748feb7a04396a6ddd3c61407d11d02aca3034f (commit) via 61733620324195c7c1a45a770e29637a74329ebd (commit) via f868f214196101712deba5c07cc60c9e43e1f9b0 (commit) via 54341c25f149263190e4ffad1c516d93a79ad3ed (commit) via 146847f922138620cb4b1ad064cc2ad8f80bb304 (commit) via 517949e31b41b303dab91670e80b207bc45d3256 (commit) via 452bd980d066101fad780815ff5ddfccdcf5e683 (commit) via f4b94df81eab2264c071a5a6f592e6becf76f770 (commit) via 2cbbcb64c997e7ed95c2e9a344347ca9606fce66 (commit) via b0f1cb2dd42338c9189c83cbcbcb177eaf1c7845 (commit) via 98cdecd68f57b4a561ac8f68a0ede4a0374a6a95 (commit) via 097c9251aaa15f702cc8b9701832dbdc1d9bcb13 (commit) via 96f2abfd9395d6f25520c3b828c4c69a0f35d8a3 (commit) via e6c42164c51c0fbef18cb02df5c5d8f37ce16ef5 (commit) via b0415f8f7e3a4af5682f22aed1885e20f3484188 (commit) via 228fb9ad5bc2e26dccbfd4f5ad2d2228bab8c39e (commit) via 39833b146ce09d18e1909ded8c81e65c250ae0c3 (commit) via 6fa6d5d33d07596f62c10f30578ce386473c2761 (commit) via 681f4ecf69ef92a8b032591c2fd17084cc037688 (commit) via f588a09ffa90a7263dc14cd5269a8d131babec7f (commit) via 1396121a4119638bbf62405dea997c9b9286583e (commit) via 37044b98d5d98d7f58ac0aa1cc1947d85c6a1ce9 (commit) via e89728ff7261807fd29cd52d3aaed6f44038f4c9 (commit) via 41247771065e2f0d364f1311e7f872553a4987c1 (commit) via dd9da418e92f1a2e61315ccc6b57385b805f4d78 (commit) via 88c783fa2524e083934fe53ea58ce3a456cfb486 (commit) via b01bc9efd100a16bd41863de3662079c9f2bea71 (commit) via 497bc6eed8e27c0f99d02fb758b7b609cf11abca (commit) via fb24639aa584bcb7280a5b10e53d58fe6c616420 (commit) via e5c1ec684199e11e0e26931abec7485befc4f572 (commit) via 6370150b19c501e4d6b9c7119ca4e2633d7ddf8b (commit) via 38cd78a54afd10a764721f93187ef6d725470ecb (commit) via f9e3bdbc5a348de93a4dbc96ef84ef94dc5f7002 (commit) via 5d8cc153b037b8c1a9f5d34dd06b6b520bebf252 (commit) via 94d743e7fbf4243b51c523d45e4aedb4e82826d7 (commit) via 77985dde32970af531f40be2005a31a46142eec7 (commit) from c213febdfa60e0b1a9a11c796911eb5b93fef90e (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 1a015d24ef172b06ffab81007174d2b42416169f Author: Akshay Srinivasan <aks...@gm...> Date: Mon Aug 22 19:08:09 2016 +0530 update pair function diff --git a/src/utilities/functions.lisp b/src/utilities/functions.lisp index d23e0c9..1fb34f4 100644 --- a/src/utilities/functions.lisp +++ b/src/utilities/functions.lisp @@ -61,8 +61,9 @@ (mapcar (lambda (args) (apply function args)) (apply #'cart list more-lists))) (declaim (inline pair)) -(defun pair (list) - (loop :for (a . b) :on list :by #'cddr :collect (if b (list a (first b)) (list a)))) +(defun pair (list &optional (n 2)) + (loop :for x :on list :by #'(lambda (x) (nthcdr n x)) + :collect (let ((xth x)) (loop :repeat n :collect (pop xth))))) (declaim (inline zip)) (defun zip (&rest args) commit dd41ced541bba5f641349f5b0477e9c2bf0a1d39 Author: Akshay Srinivasan <aks...@gm...> Date: Sat Aug 13 14:42:00 2016 +0530 added more annotations for bit/boolean types; added order->dag diff --git a/src/base/boolean.lisp b/src/base/boolean.lisp index a8b4087..3b54a97 100644 --- a/src/base/boolean.lisp +++ b/src/base/boolean.lisp @@ -5,7 +5,7 @@ (tensor 'boolean) (deft/method (t/store-allocator #'(lambda (x) (eql (field-type x) 'boolean))) (type simple-vector-store-mixin) (size &rest initargs) `(t/store-allocator ,(tensor 'bit) ,size ,@initargs)) - (deft/method (t/store-type #'(lambda (x) (eql (field-type x) 'boolean))) (type simple-vector-store-mixin) (&optional (size '*)) + (deft/method (t/store-type #'(lambda (x) (member (field-type x) '(bit boolean)))) (type simple-vector-store-mixin) (&optional (size '*)) `(simple-bit-vector ,size)) (deft/method (t/store-ref #'(lambda (x) (eql (field-type x) 'boolean))) (type simple-vector-store-mixin) (store &rest idx) diff --git a/src/base/numeric-template.lisp b/src/base/numeric-template.lisp index 7aaeab2..15c2e5b 100644 --- a/src/base/numeric-template.lisp +++ b/src/base/numeric-template.lisp @@ -167,6 +167,9 @@ (deft/method t/strict-coerce ((from rational) (to rational)) (val) `(the rational ,val)) +(deft/method t/strict-coerce ((from boolean) (to boolean)) (val) + `(the boolean ,val)) + (deft/method t/strict-coerce ((from index-type) (to index-type)) (val) `(the index-type ,val)) ;; diff --git a/src/base/tensor-template.lisp b/src/base/tensor-template.lisp index 872f447..ad54eba 100644 --- a/src/base/tensor-template.lisp +++ b/src/base/tensor-template.lisp @@ -9,6 +9,7 @@ (defun linear-storep (cl) (match (store-type cl) ((or (list 'simple-array _ (list '*)) + (list 'simple-bit-vector '*) (guard store-type (subtypep store-type 'matlisp-ffi:foreign-vector))) t))) (defun hash-table-storep (x) (eql (store-type x) 'hash-table)) @@ -81,7 +82,9 @@ (deft/method (t/store-allocator #'linear-storep) (sym tensor) (size &rest initargs) (letv* (((&key initial-element) initargs)) (with-gensyms (sitm size-sym arr idx init) - (let ((type (second (store-type sym)))) + (let ((type (ematch (store-type sym) + ((list 'simple-array type _) type) + ((list 'simple-bit-vector _) 'bit)))) `(let*-typed ((,size-sym (t/compute-store-size ,sym (let ((,sitm ,size)) (etypecase ,sitm (index-type ,sitm) diff --git a/src/graph/graph.lisp b/src/graph/graph.lisp index 3aba27a..3045a2f 100644 --- a/src/graph/graph.lisp +++ b/src/graph/graph.lisp @@ -45,6 +45,12 @@ (collect (remove-duplicates (list i (aref order i))) result-type 'vector))) type)) +(defun order->dag (order &optional type) + (adlist->graph + (iter (for i from 0 below (length order)) + (collect (remove-duplicates (list i (aref order i))) result-type 'vector)) + type)) + (defun cliquep (g lst) (iter main (for u* on lst) (iter (for v in (cdr u*)) (or (δ-i g (car u*) v) (return-from main nil))) @@ -271,7 +277,7 @@ (declare (type graph-accessor g)) (let* ((tree (t/store-allocator index-store-vector (dimensions g 0))) (start (or start (random (length tree))))) - (setf (aref tree start) start) + (iter (for i from 0 below (length tree)) (setf (aref tree i) i)) (graphfib (g g :order (lambda (x y) (if (and x y) (< x y) (and x t)))) (:init (i) (if (= i start) 0 nil)) (:update (i w-i fib) commit 60297cf076073dde534f6197f37800d02c2852b1 Merge: 037bbdb a48ffc5 Author: Akshay Srinivasan <aks...@gm...> Date: Fri Aug 5 09:22:36 2016 +0530 Merge branch 'master' of github.com:matlisp/matlisp commit 037bbdb8d29bdaa0325ad151ad2d48bf25f02e7d Author: Akshay Srinivasan <aks...@gm...> Date: Fri Aug 5 09:22:18 2016 +0530 initialize memos slot to nil. fixes issue #11. diff --git a/src/blas/maker.lisp b/src/blas/maker.lisp index a24e847..bdadbfd 100644 --- a/src/blas/maker.lisp +++ b/src/blas/maker.lisp @@ -15,7 +15,8 @@ (slot-value ,ret 'store) ,(recursive-append (when initial-element `(if ,init (t/store-allocator ,class ,tsize :initial-element (t/coerce ,(field-type class) ,init)))) `(t/store-allocator ,class ,tsize)) - (slot-value ,ret 'parent) nil) + (slot-value ,ret 'parent) nil + (slot-value ,ret 'memos) nil) ,ret))) (deft/method (t/zeros #'hash-table-storep) (class stride-accessor) (dims &optional size) commit a48ffc59bab0eff7adbb4ae41e6172b2ccf6466f Merge: e13f678 11a6dd3 Author: akssri <aks...@gm...> Date: Fri Aug 5 09:21:15 2016 +0530 Merge pull request #12 from rigetticomputing/improve_blas_func error on unknown type to BLAS-FUNC commit 11a6dd3c1f1aad5d4c322c72df5afee323d3c186 Author: Robert Smith <ro...@ri...> Date: Thu Aug 4 10:38:27 2016 -0700 error on unknown type to BLAS-FUNC diff --git a/src/base/blas-helpers.lisp b/src/base/blas-helpers.lisp index b8fc9eb..8598cef 100644 --- a/src/base/blas-helpers.lisp +++ b/src/base/blas-helpers.lisp @@ -16,14 +16,14 @@ :finally (return (values (aref sort-std 0) perm-dims sort-std std-perm))))))))) (definline blas-func (name type) - (string+ - (cond - ((eq type 'single-float) "s") - ((eq type 'double-float) "d") - ((equal type '(complex single-float)) "c") - ((equal type '(complex double-float)) "z") - (t "error: unknown BLAS type.")) - name)) + "Return the name of a given BLAS/LAPACK function whose base name is NAME operating on the type TYPE." + (let ((prefix (cond + ((eq type 'single-float) "s") + ((eq type 'double-float) "d") + ((equal type '(complex single-float)) "c") + ((equal type '(complex double-float)) "z") + (t (error "Unknown BLAS type: ~S" type))))) + (string+ prefix name))) (definline blas-copyablep (ten-a ten-b) (declare (type stride-accessor ten-a ten-b)) diff --git a/src/utilities/macros.lisp b/src/utilities/macros.lisp index 364a8b4..3c03952 100644 --- a/src/utilities/macros.lisp +++ b/src/utilities/macros.lisp @@ -184,11 +184,6 @@ (defmacro definline (name &body rest) " Creates a function and declaims them inline: short form for defining an inlined function. - - Example: - @lisp - > (macroexpand-1 `(definline f (a b) (+ a b))) - => (INLINING (DEFUN F (A B) (+ A B))) " `(progn (declaim (inline ,name)) commit e13f6788e1c3e5dea18f37379cc7872cd02e6993 Author: Akshay Srinivasan <aks...@gm...> Date: Tue Aug 2 08:42:53 2016 +0530 saving state diff --git a/src/base/base-tensor.lisp b/src/base/base-tensor.lisp index 6def410..d6c9355 100644 --- a/src/base/base-tensor.lisp +++ b/src/base/base-tensor.lisp @@ -155,6 +155,18 @@ (deftype tensor-matrix () `(and tensor (satisfies tensor-matrixp))) (deftype tensor-square-matrix () `(and tensor (satisfies tensor-matrixp) (satisfies tensor-squarep))) ;; +(deftype tensor-type (field &key tensor order square) + (let ((types (remove nil + (list (tensor field (match tensor (* nil))) + (ematch order + (1 `(satisfies tensor-vectorp)) + (2 `(satisfies tensor-matrixp)) + (* nil)) + (ematch square + ((or '* nil) nil) + (t `(satisfies tensor-squarep))))))) + (if (cdr types) (list* 'and types) (car types)))) + (closer-mop:defgeneric tensor-generator (field tensor)) (with-memoization () diff --git a/src/blas/maker.lisp b/src/blas/maker.lisp index a635dce..a24e847 100644 --- a/src/blas/maker.lisp +++ b/src/blas/maker.lisp @@ -3,15 +3,20 @@ (deft/generic (t/zeros #'subtypep) sym (dims &optional initarg)) (deft/method t/zeros (class stride-accessor) (dims &optional initial-element) - (with-gensyms (dimsv strdv tsize init) + (with-gensyms (dimsv strdv tsize init ret) `(letv* ((,dimsv (coerce ,dims 'index-store-vector) :type index-store-vector) (,strdv ,tsize (make-stride ,dimsv) :type index-store-vector index-type) - ,@(when initial-element `((,init ,initial-element)))) - (with-no-init-checks - (make-instance ',class :dimensions ,dimsv :head 0 :strides ,strdv - :store ,(recursive-append - (when initial-element `(if ,init (t/store-allocator ,class ,tsize :initial-element (t/coerce ,(field-type class) ,init)))) - `(t/store-allocator ,class ,tsize))))))) + ,@(when initial-element `((,init ,initial-element))) + ;;(,ret (sb-pcl::allocate-standard-instance ,(sb-pcl::class-wrapper (sb-pcl::ensure-class-finalized (find-class class))))) + (,ret (allocate-instance ,(find-class class)))) + (setf (slot-value ,ret 'dimensions) ,dimsv + (slot-value ,ret 'strides) ,strdv + (slot-value ,ret 'head) 0 + (slot-value ,ret 'store) ,(recursive-append + (when initial-element `(if ,init (t/store-allocator ,class ,tsize :initial-element (t/coerce ,(field-type class) ,init)))) + `(t/store-allocator ,class ,tsize)) + (slot-value ,ret 'parent) nil) + ,ret))) (deft/method (t/zeros #'hash-table-storep) (class stride-accessor) (dims &optional size) (with-gensyms (dimsv strdv tsize) diff --git a/src/graph/graph.lisp b/src/graph/graph.lisp index 012ae7d..3aba27a 100644 --- a/src/graph/graph.lisp +++ b/src/graph/graph.lisp @@ -19,7 +19,7 @@ (iter (for u in (setf (aref ag i) (sort (aref ag i) #'< :key #'(lambda (x) (etypecase x (cons (the index-type (first x))) (index-type x)))))) (letv* ((u/ value (etypecase u (cons (the index-type (values (first u) (cdr u)))) (index-type u))) (m (aref (memoizing (fence ret)) (1+ i)))) - (setf (aref (memoizing (δ-i ret) :type index-store-vector) m) u/) + (setf (aref (memoizing (δ-i ret) :type index-store-vector) m) (modproj u/ (length ag) nil)) (if value (setf (store-ref (the graph-tensor ret) m) value))) (incf (aref (memoizing (fence ret)) (1+ i)))))) ret)) @@ -42,7 +42,7 @@ (adlist->graph (symmetrize! (iter (for i from 0 below (length order)) - (collect (if (/= (aref order i) i) (list (aref order i))) result-type 'vector))) + (collect (remove-duplicates (list i (aref order i))) result-type 'vector))) type)) (defun cliquep (g lst) diff --git a/src/packages.lisp b/src/packages.lisp index 1ef1e56..a92c09a 100644 --- a/src/packages.lisp +++ b/src/packages.lisp @@ -79,7 +79,7 @@ #:maptree-if #:maptree #:maptree-eki #:pair #:compile-and-eval #:modproj ;; - #:cart #:mapcart + #:cart #:mapcart #:infer-type #:cart-case #:cart-ecase #:cart-typecase #:cart-etypecase ;; ;;string @@ -158,7 +158,7 @@ #:tensor-class #:sparse-tensor #:stride-tensor #:dense-tensor #:simple-dense-tensor #:foreign-dense-tensor #:hash-tensor - #:orphanize #:graph-tensor #:simple-graph-tensor #:coordinate-tensor #:tensor-typep + #:orphanize #:graph-tensor #:simple-graph-tensor #:coordinate-tensor #:tensor-typep #:tensor-type #:tensor-method-generator #:define-tensor-method #:cl ;;#:tensor-matrixp #:tensor-vectorp #:tensor-squarep #:tensor-vector #:tensor-matrix #:tensor-square-matrix @@ -221,7 +221,7 @@ #:base-tensor #:tensor #:memos #:store-size #:total-size #:dorefs #:for-mod #:with-iterator #:loop-order #:uplo #:sparse-tensor #:stride-tensor #:dense-tensor #:hash-tensor #:foreign-tensor - #:orphanize #:graph-tensor #:coordinate-tensor #:tensor-typep + #:orphanize #:graph-tensor #:coordinate-tensor #:tensor-typep #:tensor-type #:tensor-method-generator #:define-tensor-method #:cl ;;#:tensor-matrixp #:tensor-vectorp #:tensor-squarep #:tensor-vector #:tensor-matrix #:tensor-square-matrix diff --git a/src/special/quaternion.lisp b/src/special/quaternion.lisp index 9aa5f93..56dc171 100644 --- a/src/special/quaternion.lisp +++ b/src/special/quaternion.lisp @@ -27,8 +27,82 @@ (b b :type ,(cl :x) :strides (1))) #i(res[0] â a[1]*b[2] - a[2]*b[1], res[1] â a[2]*b[0] - a[0]*b[2], - res[2] â a[0]*b[1] - a[1]*b[0]) + res[2] â a[0]*b[1] - a[1]*b[0]) res)) + +(definline r3-cross-ss (a b) + (declare (type #.(tensor 'double-float) a b)) + (optimize-expression ((res (make-instance ' #.(tensor 'double-float) + :dimensions #.(coerce '(3) 'index-store-vector) :strides #.(make-stride (coerce '(3) 'index-store-vector)) :head 0 :store (t/store-allocator #. (tensor 'double-float) 3)) :type #.(tensor 'double-float) :strides (1)) + (a a :type #.(tensor 'double-float) :strides (1)) + (b b :type #.(tensor 'double-float) :strides (1))) + #i(res[0] â a[1]*b[2] - a[2]*b[1], + res[1] â a[2]*b[0] - a[0]*b[2], + res[2] â a[0]*b[1] - a[1]*b[0]) + res)) + +(definline r3-cross-ss (a b) + (declare (type #.(tensor 'double-float) a b)) + ;; (make-instance ' #.(tensor 'double-float) + ;; :dimensions #.(coerce '(3) 'index-store-vector) :strides #.(make-stride (coerce '(3) 'index-store-vector)) :head 0 :store (t/store-allocator #. (tensor 'double-float) 3)) + ;; #+nil + (optimize-expression ((res (t/zeros #.(tensor 'double-float) '(3)) + #+nil(make-instance ' #.(tensor 'double-float) + :dimensions (copy-seq #.(coerce '(3) 'index-store-vector)) :strides (make-stride (copy-seq #.(coerce '(3) 'index-store-vector))) :head 0 :store (t/store-allocator #. (tensor 'double-float) 3)) :type #.(tensor 'double-float) :strides (1)) + (a a :type #.(tensor 'double-float) :strides (1)) + (b b :type #.(tensor 'double-float) :strides (1))) + #i(res[0] â a[1]*b[2] - a[2]*b[1], + res[1] â a[2]*b[0] - a[0]*b[2], + res[2] â a[0]*b[1] - a[1]*b[0]) + res)) + +;; ;;#+nil +(let ((a (randn 3)) + (b (randn 3)) + (ret 0) + (dd (idxv 3)) + (ss (idxv 1))) + (declare (type #.(tensor 'double-float) a b)) + ;;(r3-cross-ss a b) + ;;(r3-cross a b) + (time (very-quickly (dotimes (i 1000) + (r3-cross-ss a b) + ;;(r3-cross-ss a b) + ;;(aref (store (r3-cross-ss a b)) 0) + ;;(incf ret (aref (store (r3-cross-ss a b)) 0)) + #+nil + (make-instance ' #.(tensor 'double-float) + :dimensions dd :strides ss :head 0 :store (t/store-allocator #. (tensor 'double-float) 3)) + ;;(make-instance 'thingy :xx 1) + ;;(make-stride dd) + ;;(t/zeros #.(tensor 'double-float) dd) + #+nil(with-no-init-checks + (make-instance ' #.(tensor 'double-float)))))) + ;;(time (very-quickly (dotimes (i 10000) (incf ret (quaternion-x (r3-cross (the #.(quaternion 'double-float) a) (the #.(quaternion 'double-float) b))))))) + ) + +(defclass tmp () (a b)) +(allocate-instance ) + +(defmethod sb-pcl::allocate-instance ((class standard-class) &rest initargs) + (declare (ignore initargs)) + (sb-pcl::allocate-standard-instance (sb-pcl::class-wrapper class))) + + +(let ((ret 0)) + (time (very-quickly (dotimes (i 1000) + ;;(sb-pcl::allocate-standard-instance (sb-pcl::class-wrapper (find-class 'tmp))) + (allocate-instance #.(find-class 'tmp)) + )))) + +(make-instance ) + +;;TODO: remove initialize-instance methods +;;TODO: add compiler-macro to zeros + +;; (remmeth #'initialize-instance `(base-accessor) '(:after)) +;; (find-method #'initialize-instance :after (mapcar #'find-class `(stride-accessor))) + ;; (defun quat-vector~ (x) (declare (type quaternion-vector x)) @@ -76,7 +150,7 @@ (q03 #i(quat[0]*quat[3]) :type ,(field-type (cl :x))) (q11 #i(quat[1]*quat[1]) :type ,(field-type (cl :x))) (q12 #i(quat[1]*quat[2]) :type ,(field-type (cl :x))) - (q13 #i(quat[1]*quat[3]) :type ,(field-type (cl :x))) + (q13 #i(quat[1]*quat[3]) :type ,(field-type (cl :x))) (q22 #i(quat[2]*quat[2]) :type ,(field-type (cl :x))) (q23 #i(quat[2]*quat[3]) :type ,(field-type (cl :x))) (q33 #i(quat[3]*quat[3]) :type ,(field-type (cl :x)))) diff --git a/src/user/function.lisp b/src/user/function.lisp index 6c2aad7..6b0786f 100644 --- a/src/user/function.lisp +++ b/src/user/function.lisp @@ -1,5 +1,13 @@ (in-package #:matlisp-user) +;;conjugate +(definline conjugate! (a) + (tensor-conjugate! a)) + +(definline conjugate (a) + (tensor-conjugate a)) +;; + (defmacro lift-function (fn &aux (pkg (find-package "MATLISP-USER"))) (letv* ((fname (symbol-name fn)) (fpkg (symbol-package fn))) (letv* ((fn (find-symbol fname fpkg)) diff --git a/src/utilities/functions.lisp b/src/utilities/functions.lisp index 7034d68..d23e0c9 100644 --- a/src/utilities/functions.lisp +++ b/src/utilities/functions.lisp @@ -193,6 +193,22 @@ (t (assert (if open? (<= (- (1+ d)) i d) (< (- (1+ d)) i d)) nil 'tensor-index-out-of-bounds) (if (< i 0) (if (and open? (= i (- (1+ d)))) -1 (mod i d)) i)))) +(defun infer-type (expr env) + (or + (match expr + ((list 'the type _) type) + ((type number) (type-of expr)) + ((list 'quote thing) (type-of thing)) + ((type null) 'null) + #+(or sbcl) + ((type symbol) + (multiple-value-bind (binding-type localp declarations) (#+sbcl sb-cltl2:variable-information + expr env) + (declare (ignore binding-type localp)) + (let ((type-decl (find 'type declarations :key #'car))) + (and type-decl (cdr type-decl)))))) + t)) + ;; (defstruct (sap-wrap (:constructor make-sap-wrap (ptr))) ;; (ptr (cffi:null-pointer) :type cffi:foreign-pointer :read-only t)) diff --git a/src/utilities/string.lisp b/src/utilities/string.lisp index 5754f76..3998754 100644 --- a/src/utilities/string.lisp +++ b/src/utilities/string.lisp @@ -34,9 +34,10 @@ returning two values: the string and the number of bytes read." (values data fsize))) (declaim (inline split-seq)) -(defun split-seq (test seq &key max-cuts) +(defun split-seq (test seqo &key max-cuts) "Split a sequence, wherever the given character occurs." - (let ((split-list nil) (split-count 0) (deletes nil)) + (let ((seq (etypecase seqo (vector seqo) (list (coerce seqo 'vector)))) + (split-list nil) (split-count 0) (deletes nil)) (labels ((left-split (prev i) (if (not deletes) (when (< prev i) @@ -78,7 +79,9 @@ returning two values: the string and the number of bytes read." (t (left-split prev i) (setf prev (1+ i))))))))) - (values (nreverse split-list) (1- split-count)))) + (values (let ((ret (nreverse split-list))) + (etypecase seqo (vector ret) (list (mapcar #'(lambda (x) (coerce x 'list)) ret)))) + (1- split-count)))) ;; (defun splitlines (string) commit 2fb104a8a34598716dca578dea5bf8c581b6a95f Author: Akshay Srinivasan <ak...@cs...> Date: Sat Jun 18 23:10:40 2016 -0700 fixed bug in roots, added regression for polyfit; fixed bug in t:.* diff --git a/src/packages.lisp b/src/packages.lisp index b0c2c06..1ef1e56 100644 --- a/src/packages.lisp +++ b/src/packages.lisp @@ -198,7 +198,7 @@ #:norm #:psd-proj #:tensor-max #:tensor-min #:tr #:ones #:eye! #:eye #:diag #:diag~ #:rand #:randn #:randi #:rande - #:range #:linspace #:polyfit #:roots) + #:range #:linspace #:polyfit #:polyval #:roots) (:documentation "MATLISP routines")) ;;Shadowed symbols. @@ -267,7 +267,7 @@ #:norm #:psd-proj #:max #:min #:tr #:ones #:eye! #:eye #:diag #:diag~ #:rand #:randn #:randi #:rande - #:range #:linspace #:polyfit #:roots) + #:range #:linspace #:polyfit #:polyval #:roots) (:documentation "MATLISP USER")) (defpackage "MATLISP-TESTS" diff --git a/src/special/poly.lisp b/src/special/poly.lisp index cbc5ebf..171df0c 100644 --- a/src/special/poly.lisp +++ b/src/special/poly.lisp @@ -1,7 +1,8 @@ (in-package #:matlisp) -(defun polyfit (observations &aux (observations (coerce observations 'vector))) - (let* ((A (zeros (list (length observations) (length observations)))) +(defun polyfit (observations &optional n &aux (observations (coerce observations 'vector))) + (let* ((n (or n (1- (length observations)))) + (A (zeros (list (length observations) (1+ n)))) (b (zeros (dimensions A 0)))) (labels ((coeff (n k) (if (< n k) 0 (iter (for jj from n downto (- n k -1)) (multiplying jj)))) @@ -9,17 +10,22 @@ (iter (for i from 0 below (dimensions x 0)) (setf (ref x i) (* (coeff i derivative) pti)) (if (<= derivative i) (setf pti (* pti ti)))))) - (iter (for li in-vector observations) - (for (Ai bi) slicing (list A b) along 0) - (ematch li - ((λlist ti value &optional (derivative 0)) - (setf (ref bi 0) value) - (row-ti ti Ai derivative)))) - (getrs! (getrf! A) b)))) + (iter (for li in-vector observations) + (for (Ai bi) slicing (list A b) along 0) + (ematch li + ((λlist ti value &optional (derivative 0)) + (setf (ref bi 0) value) + (row-ti ti Ai derivative)))) + (lstsq A b)))) + +(defun polyval (tt poly &aux (tn 1)) + (iter (for i from 0 below (dimensions poly 0)) + (summing (* (ref poly i) tn)) + (setf tn (* tn tt)))) (defun roots (poly &aux (n (1- (dimensions poly 0)))) ;;TODO: Add a better method. (let ((A (zeros (list n n) (type-of poly)))) - (copy! 1 (diag~ A 1)) + (if (< 1 n) (copy! 1 (diag~ A 1))) (scal! (/ -1 (ref poly -1)) (copy! (subtensor~ poly '((0 -1))) (subtensor~ A '(-1 (nil nil))))) - (eig A :n))) + (eig A :nn))) diff --git a/src/user/arithmetic.lisp b/src/user/arithmetic.lisp index 1ea2a85..01a0b14 100644 --- a/src/user/arithmetic.lisp +++ b/src/user/arithmetic.lisp @@ -73,11 +73,11 @@ ((tensor null) (copy ,a)))))) (definline .* (&rest objects &aux (ret (if objects (b.* (car objects)... [truncated message content] |
From: Akshay S. <ak...@us...> - 2014-05-05 17:25:34
|
This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "matlisp". The branch, tensor has been updated via 5b7710825010f450b71da9d0cbfb27411a86994e (commit) via a596730f7a5d3c3d65335ce032e8ffc3df557837 (commit) via 8b18fb736d6bae9c0fd16a0faa51efed07afb294 (commit) via f4e59e53ce5f2de3462c3c554f6bd075b3f30b6b (commit) via 6d0ed7f102650f8c775144d91c7e38901fa51ff9 (commit) via b668733e8899254c129a7b1d109b4a229aa95246 (commit) via c81e3b9bbaf654e5d5cf4b9082d013b6e0b9b1d4 (commit) via 8e9e139ab7884f3811834aba6c9eb5d25c1c79e3 (commit) via 56b707f789c453e157d0818fc8fcf0a16a699db8 (commit) via 3caa822f9516b69bc5aba4bd2cb840a05b09e48b (commit) via 3afe61642a8951b86133c79e1fbd19839f48b8b8 (commit) via 0d327c3a710ab3bce416b0ac48093557e073e6b4 (commit) via f907ad7cfb43867bce9af5226162e4d9509d9a00 (commit) via abb0a6f58d54ca9629afef9e56afbc41041ebb14 (commit) via bd8ba7b1d0ba2971f28a1690fdea106397a90d04 (commit) via e4f79071c3818c46ee389c04e01cc086497966e9 (commit) via 5e67db6057fd19bc32ff2391f2e2a1aa278448b5 (commit) via a81b698f2e9335043ee0415bbb2cf5e8539c66e8 (commit) via 6747a6d64abbad33df475d238be0be94a616df9d (commit) via adf629e94fee94dd32c4741ecec91c7567a6049a (commit) via f527df432b77c0cd1d129ac04c2ef388a6521622 (commit) via 165d6ea255110612466567fab0f1d6b7352f0f65 (commit) via e8da7463cc4af5a1ebb34f4f583e3fdf4612fcfa (commit) via 9cb26abe19d52ce5bb7fc1873a6870ebde9954a7 (commit) via 536427a4451d57ba660ed0dd09771ddcfc1b84ad (commit) via a195dc65fdc34de0b32109511a06059f2eefa701 (commit) via e9f2199b996e73e9e5f3a4836d28100bddb5dd04 (commit) via 72f1265aef1909ad6ae4ba8221a1b13374fd0036 (commit) via 312979c7214c49f9c0a2ffd29a27557be73ea104 (commit) via a1b8de0759bc21deecec1b44462dbb022f30c768 (commit) via 313c41e3170fff67f8495ddac3fc084d0dbbeb92 (commit) via 2a305a1aabb5d33c5c1967e257d3802d66e2c0fc (commit) via 59cc9209020a6f3f22a04760a7af7292b8959526 (commit) via 25502e745746d57cb0255579aad4c3fad9cbb206 (commit) via e7b1e34c36d42dd0a7d651b3ec3f4dee514dd44b (commit) via e5d57952737b7558a81583609ae97dbd77b9b557 (commit) via 6e9a51f360bdf55d86c0c905e836daeaa98f7bc3 (commit) via 5f6a1194181a0702e3f8a67f401ef34eb8863c36 (commit) via 0fad8e8adfab324824eb5be7bda579ed366f0a89 (commit) via fb6d6c916959ee249a6d1e4726019307bdb29f0a (commit) via 144f7817e8eb11597f795a76dbda9c6371b61c0b (commit) via b301eaf23d1815d9d1521ceebf0d669e98f3170a (commit) via f98c528e0f88148fe96c5c34cd085a0281bdd9fa (commit) via 5b3e1bbdcd79e00b2dcd251d85dcd42f7e333cdd (commit) via a6b74d7ce09d42adeeab287b8a4cce1fd47c58cb (commit) via 24b661d49484fd9774bebf80c07c6dc836f69779 (commit) via 731e677c5e9d7eb73033fbcbb78be1ab2987d5b0 (commit) via c14d06055ad9164df1e9fe34ea2d285722134772 (commit) via e17ae2b44b5956cb4a4ec3339273f1e208f501ae (commit) via 1560a36faab44c6f9d293c57693045ebd21ca96b (commit) via 5461bd2ef8e0e6b06b3977117de61d13d531600d (commit) via 8198d66eaf11fef2717f452c4c41da00a2e1b429 (commit) via 33d2c5fd06d3e60aead58431e268a2e42d7ea367 (commit) via 9dc526079f9cc2b5a9e5c57d7c4b54236a385263 (commit) via 6a5d74a7599f4ca6a8afcfaadfdc7b0c3c237bbd (commit) via 7d21471d9da7de10e6a830dc0259efc17e8aa840 (commit) via 3c4398cc36783ea7a321fbdc331b1160c35bebb4 (commit) via 00de47b9b5cb595a23b37e2d98d2f2fdeb92dcba (commit) via dd1f88674eb90b3af6743dae3cb48fcbf73b9a9a (commit) via b34c2cbf5974f6f7f5c20dbb86a424cdcd88fd50 (commit) via b3efc3a5938126c1010dec87d2a9d8b35d42b5ec (commit) via c4f19e17ff8eaa53b4dc52ad6054fa0611700a66 (commit) via 6833afe74673a047fa5916c95d91b76a1e449028 (commit) via 0a01c0e5591324a538b86cbe8405e7a7f6639034 (commit) via 5b70afc8934b8ca3116fd79b78eaa2a244f8d60c (commit) via d085bd096912a652b2a620821669f7dea5b5649e (commit) via 8df18050e19d4de26f326c870454f46af872de12 (commit) via cb63f4927ad9d371a675ddc995df9119bc7afc17 (commit) via 9621836c207ba1fe67ef27eb0f5f1d4b7287d849 (commit) from 6cfc62a0b8737f16a23c7c971cd5055fefb42750 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 5b7710825010f450b71da9d0cbfb27411a86994e Author: Akshay Srinivasan <ak...@cs...> Date: Sat May 3 17:24:20 2014 -0700 Added fibonacci.lisp to ASDF. diff --git a/matlisp.asd b/matlisp.asd index f6bccd0..5624aa8 100644 --- a/matlisp.asd +++ b/matlisp.asd @@ -188,7 +188,11 @@ (:module "matlisp-reader" :pathname "reader" :components ((:file "infix") - (:file "loadsave"))))) + (:file "loadsave"))) + (:module "matlisp-graph" + :pathname "graph" + :depends-on ("matlisp-base" "matlisp-classes" "matlisp-blas" "matlisp-lapack") + :components ((:file "fibonacci"))))) ;; (defclass f2cl-cl-source-file (asdf:cl-source-file) commit a596730f7a5d3c3d65335ce032e8ffc3df557837 Author: Akshay Srinivasan <aks...@gm...> Date: Sat May 3 17:19:20 2014 -0700 Added cs-matrix -> standard tensor copy method. diff --git a/src/blas/copy.lisp b/src/blas/copy.lisp index 29b2c73..35df0b3 100644 --- a/src/blas/copy.lisp +++ b/src/blas/copy.lisp @@ -102,7 +102,24 @@ ,y)))) ;; -;;(t/copy! (real-coordinate-sparse-tensor real-compressed-sparse-matrix) x y) +(deft/method t/copy! ((clx t) (cly standard-tensor)) (x y) + (using-gensyms (decl (x y)) + (with-gensyms (sto-y of-y idx cx) + `(let* (,@decl + (,sto-y (store ,y)) + (,cx (t/coerce ,(field-type cly) ,x))) + (declare (type ,cly ,y) + (type ,(field-type cly) ,cx) + (type ,(store-type cly) ,sto-y)) + ;;This should be safe + (very-quickly + (mod-dotimes (,idx (dimensions ,y)) + :with (linear-sums + (,of-y (strides ,y) (head ,y))) + :do (t/store-set ,cly ,cx ,sto-y ,of-y))) + ,y)))) + +;; (deft/method t/copy! ((clx coordinate-sparse-tensor) (cly compressed-sparse-matrix)) (x y) (using-gensyms (decl (x y) (rstd cstd rdat key value r c s? v vi vr vd i col-stop row)) `(let (,@decl) @@ -116,7 +133,7 @@ :do (multiple-value-bind (,c ,r) (floor (the index-type ,key) ,cstd) (multiple-value-bind (,r ,s?) (floor (the index-type ,r) ,rstd) (when (zerop ,s?) - (push (cons ,c (t/coerce ,(field-type cly) ,value)) (aref ,rdat ,r)))))) + (push (cons ,c `(t/strict-coerce (,(field-type clx) ,(field-type cly)) ,value)) (aref ,rdat ,r)))))) (loop :for ,key :being :the :hash-keys :of (store ,x) :using (hash-value ,value) :do (multiple-value-bind (,c ,r) (floor (the index-type ,key) ,cstd) @@ -141,6 +158,25 @@ (setf (aref ,vi (1+ ,i)) ,col-stop))))) ,y)))) +(deft/method t/copy! ((clx compressed-sparse-matrix) (cly standard-tensor)) (x y) + (using-gensyms (decl (x y) (vi vr vd i j)) + `(let (,@decl) + (declare (type ,clx ,x) (type ,cly ,y)) + (copy! (t/fid+ ,(field-type cly)) ,y) + (let-typed ((,vi (neighbour-start ,x) :type index-store-vector) + (,vr (neighbour-id ,x) :type index-store-vector) + (,vd (store ,x) :type ,(store-type clx))) + (if (transpose? ,x) + (very-quickly + (loop :for ,j :from 0 :below (length ,vi) + :do (loop :for ,i :from (aref ,vi ,j) :below (aref ,vi (1+ ,j)) + :do (setf (ref ,y ,j (aref ,vr ,i)) (t/strict-coerce (,(field-type clx) ,(field-type cly)) (aref ,vd ,i)))))) + (very-quickly + (loop :for ,j :from 0 :below (length ,vi) + :do (loop :for ,i :from (aref ,vi ,j) :below (aref ,vi (1+ ,j)) + :do (setf (ref ,y (aref ,vr ,i) ,j) (t/strict-coerce (,(field-type clx) ,(field-type cly)) (aref ,vd ,i)))))))) + ,y))) + ;; (deft/method t/copy! ((clx compressed-sparse-matrix) (cly coordinate-sparse-tensor)) (x y) ;; (using-gensyms (decl (x y) (cstd rdat key value r c v vi vr vd i col-stop row)) ;; `(let (,@decl) @@ -150,8 +186,7 @@ ;; (,vd (store ,x) :type ,(store-type cly))) ;; (loop :for i :from 0 :below (1- (length ,vi)) ;; :do (loop :for j :from (aref ,vi i) :below (aref ,vi (1+ i)) -;; :do (setf - +;; :do (setf ;; (let ((,cstd (aref (strides ,x) 1)) ;; (,rdat (make-array (ncols ,x) :initial-element nil))) ;; (loop :for ,key :being :the :hash-keys :of (store ,x) @@ -173,22 +208,6 @@ ;; (setf (aref ,vi (1+ ,i)) ,col-stop))))) ;; ,y)))) ;; -(deft/method t/copy! ((clx t) (cly standard-tensor)) (x y) - (using-gensyms (decl (x y)) - (with-gensyms (sto-y of-y idx cx) - `(let* (,@decl - (,sto-y (store ,y)) - (,cx (t/coerce ,(field-type cly) ,x))) - (declare (type ,cly ,y) - (type ,(field-type cly) ,cx) - (type ,(store-type cly) ,sto-y)) - ;;This should be safe - (very-quickly - (mod-dotimes (,idx (dimensions ,y)) - :with (linear-sums - (,of-y (strides ,y) (head ,y))) - :do (t/store-set ,cly ,cx ,sto-y ,of-y))) - ,y)))) ;; (defmethod copy! :before ((x base-tensor) (y base-tensor)) @@ -198,7 +217,7 @@ (defmethod copy! :before ((a base-tensor) (b compressed-sparse-matrix)) (assert (<= (store-size a) (store-size b)) nil 'tensor-insufficient-store)) -(defmethod copy! ((x standard-tensor) (y standard-tensor)) +(defmethod copy! ((x base-tensor) (y base-tensor)) (let ((clx (class-name (class-of x))) (cly (class-name (class-of y)))) (assert (and (member clx *tensor-type-leaves*) @@ -223,41 +242,6 @@ (error "Don't know how to copy from ~a to ~a" clx cly)))) (copy! x y)) -(defmethod copy! ((x coordinate-sparse-tensor) (y compressed-sparse-matrix)) - (let ((clx (class-name (class-of x))) - (cly (class-name (class-of y)))) - (assert (and (member clx *tensor-type-leaves*) - (member cly *tensor-type-leaves*)) - nil 'tensor-abstract-class :tensor-class (list clx cly)) - (compile-and-eval - `(defmethod copy! ((x ,clx) (y ,cly)) - (let-typed ((stds (strides x) :type index-store-vector)) - (assert (and (tensor-matrixp x) (= (aref stds 0) 1)) nil 'tensor-invalid-stride-value) - (let ((col-stride (aref stds 1)) - (row-data (make-array (ncols x) :initial-element nil))) - (very-quickly - (loop :for key :being :the :hash-keys :of (store x) - :using (hash-value value) - :do (multiple-value-bind (c r) (floor (the index-type key) col-stride) - (push (cons r value) (aref row-data c))))) - (let-typed ((vi (neighbour-start y) :type index-store-vector) - (vr (neighbour-id y) :type index-store-vector) - (vd (store y) :type ,(store-type cly))) - (setf (aref vi 0) 0) - (very-quickly - (loop :for i :from 0 :below (ncols x) - :with col-stop := 0 - :do (let ((rowd (sort (aref row-data i) #'(lambda (x y) (< (the index-type x) (the index-type y))) :key #'car))) - (loop :for (r . v) :in rowd - :do (locally - (declare (type ,(field-type clx) v)) - (setf (aref vr col-stop) r) - (t/store-set real-compressed-sparse-matrix (t/coerce ,(field-type cly) v) vd col-stop) - (incf col-stop))) - (setf (aref vi (1+ i)) col-stop))))) - y)))) - (copy! x y))) - (defmethod copy! ((x t) (y standard-tensor)) (let ((cly (class-name (class-of y)))) (assert (and (member cly *tensor-type-leaves*)) @@ -337,4 +321,7 @@ ((or (not type) (subtypep type 'sparse-tensor)) (let ((ret (zeros (dimensions tensor) (or type (class-of tensor)) (store-size tensor)))) (copy! tensor ret))) + ((subtypep type 'standard-tensor) + (let ((ret (zeros (dimensions tensor) type (store-size tensor)))) + (copy! tensor ret))) (t (error "don't know how to copy ~a into ~a." (class-name (class-of tensor)) type)))) commit 8b18fb736d6bae9c0fd16a0faa51efed07afb294 Author: Akshay Srinivasan <aks...@gm...> Date: Fri Apr 25 20:35:41 2014 -0700 Made changes to accomodate negative axis in mapslice; fixed bugs in chol, t/store-ref. diff --git a/src/base/base-tensor.lisp b/src/base/base-tensor.lisp index f0d8f99..349a9df 100644 --- a/src/base/base-tensor.lisp +++ b/src/base/base-tensor.lisp @@ -270,16 +270,21 @@ (let ((nd (ceiling (- end start) inc))) (when (<= nd 0) (return (values -1 nil nil))) (incf hd (* s start)) - (when (or preserve-rank (> nd 1)) + (when (or preserve-rank (> nd 1) (= nd d)) (collect nd into dims) (collect (* inc s) into stds)))) (finally (return (if (and ref-single-element? (null dims)) (values hd nil nil) (values hd (or dims (list 1)) (or stds (list 1))))))))) +(definline modproj (i d &optional open?) + (assert (if open? (<= (1- (- d)) i d) (< (1- (- d)) i d)) nil 'invalid-value) + (if (< i 0) (mod i d) i)) + (definline slice~ (x axis &optional (idx 0) (preserve-rank? nil)) - (let ((slst (make-list (order x) :initial-element '(nil nil)))) - (rplaca (nthcdr axis slst) (list idx (1+ idx))) + (let ((slst (make-list (order x) :initial-element '(nil nil))) + (axis (modproj axis (order x)))) + (rplaca (nthcdr (mod axis (order x)) slst) (list idx (1+ (modproj idx (aref (dimensions x) axis))))) (subtensor~ x slst preserve-rank? nil))) (definline row-slice~ (x idx) diff --git a/src/base/tensor-template.lisp b/src/base/tensor-template.lisp index 1ce0d3f..3ef0542 100644 --- a/src/base/tensor-template.lisp +++ b/src/base/tensor-template.lisp @@ -43,12 +43,13 @@ (define-setf-expander t/store-ref (sym store &rest idx &environment env) (multiple-value-bind (dummies vals newval setter getter) (get-setf-expansion store env) + (declare (ignore newval setter)) (with-gensyms (nval) (values dummies vals `(,nval) `(t/store-set ,sym ,nval ,getter ,@idx) - `(t/store-get ,sym ,getter ,@idx))))) + `(t/store-ref ,sym ,getter ,@idx))))) ;;standard-tensor specific. ;;Beware of infinite loops here. diff --git a/src/lapack/chol.lisp b/src/lapack/chol.lisp index f5c4f14..a3c1fb9 100644 --- a/src/lapack/chol.lisp +++ b/src/lapack/chol.lisp @@ -149,14 +149,16 @@ :given uplo :expected `(member uplo '(:u :l))))) (define-tensor-method potrs! ((A blas-numeric-tensor :input) (B blas-numeric-tensor :output) &optional (uplo *default-uplo*)) - `(with-columnification (((A #\C)) (B)) - (multiple-value-bind (sto info) (t/lapack-potrs! ,(cl a) - A (or (blas-matrix-compatiblep A #\N) 0) - B (or (blas-matrix-compatiblep B #\N) 0) - (aref (symbol-name uplo) 0)) - (declare (ignore sto)) - (unless (= info 0) - (error "POTRS returned ~a. the ~:*~a'th argument had an illegal value." (- info))))) + `(if (tensor-vectorp B) + (potrs! A (suptensor~ B 2) uplo) + (with-columnification (((A #\C)) (B)) + (multiple-value-bind (sto info) (t/lapack-potrs! ,(cl a) + A (or (blas-matrix-compatiblep A #\N) 0) + B (or (blas-matrix-compatiblep B #\N) 0) + (aref (symbol-name uplo) 0)) + (declare (ignore sto)) + (unless (= info 0) + (error "POTRS returned ~a. the ~:*~a'th argument had an illegal value." (- info)))))) 'B) ;; (defgeneric chol (a &optional uplo) diff --git a/src/reader/infix.lisp b/src/reader/infix.lisp index 67daf7a..2927657 100644 --- a/src/reader/infix.lisp +++ b/src/reader/infix.lisp @@ -19,7 +19,7 @@ ;; Where should setf and friends go in the precedence? ( = += -= *= /=) (|:|) ;;slicing - ( \, newline ) ; progn (statement delimiter) + ( \, ) ; progn (statement delimiter) ( \] \) ) ( %infix-end-token% )) ; end of infix expression "Ordered list of operators of equal precedence.") @@ -653,19 +653,19 @@ (define-token-operator \, :infix `(progn ,left ,(gather-superiors '\, stream))) -(define-character-tokenization #\Newline - #'(lambda (stream char) - (declare (ignore char stream)) - 'newline)) - -(define-token-operator newline - :infix (progn - (ignore-characters +blank-characters+ stream) - (case (peek-char nil stream t nil t) - (#\) - left) - (t - `(progn ,left ,(gather-superiors 'newline stream)))))) +;; (define-character-tokenization #\Newline +;; #'(lambda (stream char) +;; (declare (ignore char stream)) +;; 'newline)) + +;; (define-token-operator newline +;; :infix (progn +;; (ignore-characters +blank-characters+ stream) +;; (case (peek-char nil stream t nil t) +;; (#\) +;; left) +;; (t +;; `(progn ,left ,(gather-superiors 'newline stream)))))) ;;---------------------------------------------------------------;; (define-character-tokenization #\= diff --git a/src/special/map.lisp b/src/special/map.lisp index ab7b192..50f6128 100644 --- a/src/special/map.lisp +++ b/src/special/map.lisp @@ -72,16 +72,22 @@ ;; (defun check-dims (axis tensors) - (loop :for x :of-type standard-tensor :in tensors - :with dims := nil - :do (let-typed ((xdims (dimensions x) :type index-store-vector)) - (assert (< axis (order x)) nil 'tensor-dimension-mismatch) - (if (null dims) - (setf dims (aref xdims axis)) - (setf dims (min (aref xdims axis) dims)))) - :collect (aref (strides x) axis) :into strides - :collect (slice~ x axis) :into slices - :finally (return (values dims strides slices)))) + (iter (for x in tensors) + (with dims = nil) + (cond + ((typep x 'standard-tensor) + (let-typed ((xdims (dimensions x) :type index-store-vector)) + (assert (< axis (order x)) nil 'tensor-dimension-mismatch) + (if (null dims) + (setf dims (aref xdims (mod axis (order x)))) + (setf dims (min (aref xdims (mod axis (order x))) dims)))) + (collect (aref (strides x) (mod axis (order x))) into strides) + (collect (slice~ x axis) into slices)) + ((eq x nil) + (collect nil into strides) + (collect nil into slices)) + (t (error 'invalid-arguments))) + (finally (return (values dims strides slices))))) (defun mapslice (axis func tensor &rest more-tensors) (multiple-value-bind (d.axis strides slices) (check-dims axis (cons tensor more-tensors)) @@ -90,7 +96,7 @@ (when (< i (1- d.axis)) (loop :for slc :in slices :for std :in strides - :do (incf (slot-value slc 'head) std))))))) + :do (when slc (incf (slot-value slc 'head) std)))))))) (defun mapslice~ (axis func tensor &rest more-tensors) (multiple-value-bind (d.axis strides slices) (check-dims axis (cons tensor more-tensors)) @@ -99,7 +105,7 @@ (when (< i (1- d.axis)) (loop :for slc :in slices :for std :in strides - :do (incf (slot-value slc 'head) std))))))) + :do (when slc (incf (slot-value slc 'head) std)))))))) (defun mapslicec~ (axis func tensor &rest more-tensors) (multiple-value-bind (d.axis strides slices) (check-dims axis (cons tensor more-tensors)) @@ -108,7 +114,7 @@ (when (< i (1- d.axis)) (loop :for slc :in slices :for std :in strides - :do (incf (slot-value slc 'head) std)))))) + :do (when slc (incf (slot-value slc 'head) std))))))) (values-list (cons tensor more-tensors))) ;; diff --git a/src/special/norm.lisp b/src/special/norm.lisp index 2ce9a29..f4018bd 100644 --- a/src/special/norm.lisp +++ b/src/special/norm.lisp @@ -55,3 +55,6 @@ (setf rval r) (lvec->list! idx ridx)))) (values rval ridx)))) + +(defun tr (mat) + (sum (tricopy! mat (zeros (lvec-min (dimensions mat)) (class-of mat)) :d))) commit f4e59e53ce5f2de3462c3c554f6bd075b3f30b6b Author: Akshay Srinivasan <aks...@gm...> Date: Fri Apr 18 12:39:43 2014 -0700 Fixed bug in potrs, made suptensor~ choose strides more wisely. diff --git a/src/base/standard-tensor.lisp b/src/base/standard-tensor.lisp index 82f9eaa..aed16f2 100644 --- a/src/base/standard-tensor.lisp +++ b/src/base/standard-tensor.lisp @@ -193,9 +193,9 @@ (let ((tord (order ten))) (unless (integerp start) (setq start (if start (- ord tord) 0))) - (let ((stds (make-index-store (append (make-list start :initial-element 1) + (let ((stds (make-index-store (append (make-list start :initial-element (size ten)) (lvec->list (strides ten)) - (make-list (- ord tord start) :initial-element 1)))) + (make-list (- ord tord start) :initial-element (size ten))))) (dims (make-index-store (append (make-list start :initial-element 1) (dims ten) (make-list (- ord tord start) :initial-element 1))))) diff --git a/src/lapack/chol.lisp b/src/lapack/chol.lisp index 27bb8cc..f5c4f14 100644 --- a/src/lapack/chol.lisp +++ b/src/lapack/chol.lisp @@ -142,21 +142,21 @@ Solution could not be computed. ") (:method :before ((A standard-tensor) (B standard-tensor) &optional (uplo :l)) - (assert (and (tensor-matrixp A) (tensor-matrixp B) - (= (nrows A) (ncols A) (nrows B))) + (assert (and (tensor-square-matrixp A) (<= (order B) 2) + (= (nrows A) (nrows B))) nil 'tensor-dimension-mismatch) (assert (member uplo '(:l :u)) nil 'invalid-value :given uplo :expected `(member uplo '(:u :l))))) (define-tensor-method potrs! ((A blas-numeric-tensor :input) (B blas-numeric-tensor :output) &optional (uplo *default-uplo*)) - `(with-columnification ((A #\C) (B)) + `(with-columnification (((A #\C)) (B)) (multiple-value-bind (sto info) (t/lapack-potrs! ,(cl a) A (or (blas-matrix-compatiblep A #\N) 0) B (or (blas-matrix-compatiblep B #\N) 0) (aref (symbol-name uplo) 0)) (declare (ignore sto)) (unless (= info 0) - (error "POTRS returned ~a. the ~a'th argument had an illegal value." (- info))))) + (error "POTRS returned ~a. the ~:*~a'th argument had an illegal value." (- info))))) 'B) ;; (defgeneric chol (a &optional uplo) commit 6d0ed7f102650f8c775144d91c7e38901fa51ff9 Author: Akshay Srinivasan <aks...@gm...> Date: Fri Apr 18 02:16:49 2014 -0700 Added a transpose-optimization to t*. diff --git a/src/sugar/arithmetic.lisp b/src/sugar/arithmetic.lisp index add10be..33b4221 100644 --- a/src/sugar/arithmetic.lisp +++ b/src/sugar/arithmetic.lisp @@ -101,10 +101,35 @@ ;; :finally (return (cost 0 (1- n))))))) -(definline t* (&rest objs) - (reduce #'tb* objs)) -(definline m* (&rest objs) - (apply #'t* objs)) +(defmacro t* (&rest objs) + (labels ((op (code) + (when (consp code) + (case (car code) + (htranspose #\C) + (transpose #\T)))) + (optimizer (a b) + (let ((op.a (op a)) + (op.b (op b))) + (if (not (or op.a op.b)) + `(tb* ,a ,b) + (with-gensyms (ma mb) + `(let ((,ma ,(if op.a (cadr a) a)) + (,mb ,(if op.b (cadr b) b))) + ;;This will not throw errors that one would expect, sometimes. + (if (and (tensor-matrixp ,ma) (tensor-matrixp ,mb)) + (gemm 1 ,ma ,mb nil nil ,(intern (coerce (list (or op.a #\N) (or op.b #\N)) 'string) :keyword)) + (tb* ,(if op.a `(,(car a) ,ma) ma) ,(if op.b `(,(car b) ,mb) mb)))))))) + (ropt (lst) + (if (not (cdr lst)) (car lst) + (ropt (cons (optimizer (first lst) (second lst)) (cddr lst)))))) + (ropt objs))) + +(defmacro m* (&rest objs) + `(t* ,@objs)) +;; (definline t* (&rest objs) +;; (reduce #'tb* objs)) +;; (definline m* (&rest objs) +;; (apply #'t* objs)) ;; (definline t.* (&rest objs) (reduce #'scal objs)) commit b668733e8899254c129a7b1d109b4a229aa95246 Author: Akshay Srinivasan <aks...@gm...> Date: Fri Apr 18 01:40:13 2014 -0700 Changed print to col-major; infix now uses the dispatch table for regular reads. diff --git a/src/base/print.lisp b/src/base/print.lisp index df5f7e8..66d168b 100644 --- a/src/base/print.lisp +++ b/src/base/print.lisp @@ -53,14 +53,14 @@ of a matrix (default 0) (two-print-calls 0)) (labels ((two-print (tensor subs) (let ((strs nil) - (maxw (make-array (if (eq *print-max-len* t) (aref dims (- rank 1)) (1+ *print-max-len*)) :initial-element 0))) + (maxw (make-array (if (eq *print-max-len* t) (aref dims 1) (1+ *print-max-len*)) :initial-element 0))) (setq strs - (iter (for i from 0 below (aref dims (- rank 2))) + (iter (for i from 0 below (aref dims 0)) (if (or (eq *print-max-len* t) (< i *print-max-len*)) - (collect (iter (for j from 0 below (aref dims (- rank 1))) + (collect (iter (for j from 0 below (aref dims 1)) (if (or (eq *print-max-len* t) (< j *print-max-len*)) (let ((str (with-output-to-string (str) - (print-element tensor (ref tensor (append subs `(,i ,j))) str)))) + (print-element tensor (ref tensor (append `(,i ,j) subs)) str)))) (collect str into cprints) (setf (aref maxw j) (max (aref maxw j) (length str)))) (let ((str (with-output-to-string (str) (format str "...")))) @@ -77,17 +77,17 @@ of a matrix (default 0) (for j initially 0 then (1+ j)) (format stream (replace (make-string (+ (aref maxw j) 4) :initial-element #\Space) cref :start1 (if (char= (aref cref 0) #\-) 0 1)))) (format stream "~%")) - (unless (or (eq *print-max-len* t) (< (aref dims (- rank 2)) *print-max-len*)) + (unless (or (eq *print-max-len* t) (< (aref dims 0) *print-max-len*)) (format stream (format nil "~~~AT.~~%~~~:*~AT:~~%" *print-indent*))))) (rec-print (tensor idx subs) - (if (< idx (- rank 2)) + (if (>= idx 2) (dotimes (i (aref dims idx) t) - (unless (rec-print tensor (1+ idx) (append subs `(,i))) + (unless (rec-print tensor (1- idx) (append `(,i) subs)) (return nil))) (progn (if (or (eq *print-max-args* t) (< two-print-calls *print-max-args*)) (progn - (format stream "~A~%" (append subs '(\: \:))) + (format stream "~A~%" (append '(\: \:) subs)) (two-print tensor subs) (format stream "~%") (incf two-print-calls) @@ -111,7 +111,7 @@ of a matrix (default 0) (2 (two-print tensor nil)) (t - (rec-print tensor 0 nil)))))) + (rec-print tensor (1- (order tensor)) nil)))))) (defmethod print-object ((tensor standard-tensor) stream) (print-unreadable-object (tensor stream :type t) diff --git a/src/reader/infix.lisp b/src/reader/infix.lisp index 4e55df6..67daf7a 100644 --- a/src/reader/infix.lisp +++ b/src/reader/infix.lisp @@ -200,7 +200,7 @@ result)) (defun read-regular (stream) - (with-readtable (:common-lisp) + (with-readtable (:infix-dispatch-table) (read stream t nil t))) ;;; Hack to work around + and - being terminating macro characters, commit c81e3b9bbaf654e5d5cf4b9082d013b6e0b9b1d4 Author: Akshay Srinivasan <ak...@cs...> Date: Mon Apr 14 21:35:26 2014 -0700 Fixed bug in print.lisp, added u8-tensor. diff --git a/src/base/print.lisp b/src/base/print.lisp index a22524a..df5f7e8 100644 --- a/src/base/print.lisp +++ b/src/base/print.lisp @@ -77,7 +77,7 @@ of a matrix (default 0) (for j initially 0 then (1+ j)) (format stream (replace (make-string (+ (aref maxw j) 4) :initial-element #\Space) cref :start1 (if (char= (aref cref 0) #\-) 0 1)))) (format stream "~%")) - (unless (or (< (aref dims (- rank 2)) *print-max-len*) (eq *print-max-len* t)) + (unless (or (eq *print-max-len* t) (< (aref dims (- rank 2)) *print-max-len*)) (format stream (format nil "~~~AT.~~%~~~:*~AT:~~%" *print-indent*))))) (rec-print (tensor idx subs) (if (< idx (- rank 2)) diff --git a/src/classes/numeric.lisp b/src/classes/numeric.lisp index c046caa..9e6e63a 100644 --- a/src/classes/numeric.lisp +++ b/src/classes/numeric.lisp @@ -15,6 +15,10 @@ (defleaf fixnum-tensor (numeric-tensor) ()) (deft/method t/field-type (sym fixnum-tensor) () 'fixnum) + +(defleaf u8-tensor (numeric-tensor) ()) +(deft/method t/field-type (sym u8-tensor) () + '(unsigned-byte 8)) ;; (defclass blas-numeric-tensor (numeric-tensor) ()) (deft/generic (t/l1-lb #'subtypep) sym ()) commit 8e9e139ab7884f3811834aba6c9eb5d25c1c79e3 Author: Akshay Srinivasan <aks...@gm...> Date: Mon Apr 14 11:49:40 2014 -0700 Tweaked the definitions for foreign stores, made mapslice more general. diff --git a/src/base/coordinate-sparse.lisp b/src/base/coordinate-sparse.lisp index 12bdfa9..25c9968 100644 --- a/src/base/coordinate-sparse.lisp +++ b/src/base/coordinate-sparse.lisp @@ -7,22 +7,23 @@ (strides :initarg :strides :reader strides :type index-store-vector :documentation "Strides for accesing elements of the tensor."))) -(defmethod initialize-instance :after ((tensor coordinate-sparse-tensor) &rest initargs) - (declare (ignore initargs)) - (when *check-after-initializing?* - (let-typed ((dims (dimensions tensor) :type index-store-vector)) - (assert (>= (head tensor) 0) nil 'tensor-invalid-head-value :head (head tensor) :tensor tensor) - (if (not (slot-boundp tensor 'strides)) - (setf (slot-value tensor 'strides) (make-stride-cmj dims)) - (very-quickly - (let-typed ((stds (strides tensor) :type index-store-vector)) - (loop :for i :of-type index-type :from 0 :below (order tensor) - :for sz :of-type index-type := (aref dims 0) :then (the index-type (* sz (aref dims i))) - :for lidx :of-type index-type := (the index-type (* (aref stds 0) (1- (aref dims 0)))) :then (the index-type (+ lidx (the index-type (* (aref stds i) (1- (aref dims i)))))) - :do (progn - (assert (> (aref stds i) 0) nil 'tensor-invalid-stride-value :argument i :stride (aref stds i) :tensor tensor) - (assert (> (aref dims i) 0) nil 'tensor-invalid-dimension-value :argument i :dimension (aref dims i) :tensor tensor)) - :finally (assert (>= (the index-type (store-size tensor)) (the index-type (+ (the index-type (head tensor)) lidx))) nil 'tensor-insufficient-store :store-size (store-size tensor) :max-idx lidx :tensor tensor)))))))) +;; (defmethod initialize-instance :after ((tensor coordinate-sparse-tensor) &rest initargs) +;; (declare (ignore initargs)) +;; (when *check-after-initializing?* +;; (let-typed ((dims (dimensions tensor) :type index-store-vector)) +;; (assert (>= (head tensor) 0) nil 'tensor-invalid-head-value :head (head tensor) :tensor tensor) +;; (if (not (slot-boundp tensor 'strides)) +;; (setf (slot-value tensor 'strides) (make-stride-cmj dims)) +;; (very-quickly +;; (let-typed ((stds (strides tensor) :type index-store-vector)) +;; (loop :for i :of-type index-type :from 0 :below (order tensor) +;; :for s :across stds +;; :for d :across dims +;; :summing (the index-type (* s d)) :into sz :of-type index-type +;; :do (progn +;; (assert (and (>= s sz) (> s 0)) nil 'tensor-invalid-stride-value :argument i :stride s :tensor tensor) +;; (assert (> d 0) nil 'tensor-invalid-dimension-value :argument i :dimension d :tensor tensor)) +;; :finally (assert (>= (the index-type (store-size tensor)) (the index-type (+ (the index-type (head tensor)) lidx))) nil 'tensor-insufficient-store :store-size (store-size tensor) :max-idx lidx :tensor tensor)))))))) (deft/generic (t/sparse-fill #'subtypep) sym ()) (deft/method t/sparse-fill (sym sparse-tensor) () diff --git a/src/classes/foreign.lisp b/src/classes/foreign.lisp index c277850..e8e9a8a 100644 --- a/src/classes/foreign.lisp +++ b/src/classes/foreign.lisp @@ -9,21 +9,25 @@ 'foreign-vector) (deft/method t/store-size (sym foreign-numeric-tensor) (vec) `(fv-size ,vec)) -(deft/method t/store-ref (sym foreign-numeric-tensor) (store idx) - `(the ,(field-type sym) (fv-ref ,store ,idx))) -(deft/method t/store-set (sym foreign-numeric-tensor) (value store idx) - `(setf (fv-ref ,store ,idx) (the ,(field-type sym) ,value))) +(deft/method t/store-ref (sym foreign-numeric-tensor) (store &rest idx) + (assert (null (cdr idx)) nil "given more than one index for linear-store") + `(the ,(field-type sym) (fv-ref ,store ,(car idx)))) + +(deft/method t/store-set (sym foreign-numeric-tensor) (value store &rest idx) + (assert (null (cdr idx)) nil "given more than one index for linear-store") + `(setf (fv-ref ,store ,(car idx)) (the ,(field-type sym) ,value))) + +;; (eval-when (:compile-toplevel :load-toplevel :execute) - (defgeneric cl->cffi-type (type) - (:method (type) - (ecase type - (character :char) - (single-float :float) - (double-float :double) - (string :string) - (t (error 'unknown-token :token type - :message "Don't know how to convert type to CFFI.")))))) + (definline cl->cffi-type (type) + (ecase type + (character :char) + (single-float :float) + (double-float :double) + (string :string) + (t (error 'unknown-token :token type + :message "Don't know how to convert type to CFFI."))))) (deft/method with-field-element (sym foreign-numeric-tensor) (decl &rest body) (destructuring-bind (var val &optional (count 1)) decl diff --git a/src/special/map.lisp b/src/special/map.lisp index 10de493..ab7b192 100644 --- a/src/special/map.lisp +++ b/src/special/map.lisp @@ -75,16 +75,13 @@ (loop :for x :of-type standard-tensor :in tensors :with dims := nil :do (let-typed ((xdims (dimensions x) :type index-store-vector)) - (assert (or (not dims) (= (order x) (length dims))) nil 'tensor-dimension-mismatch) + (assert (< axis (order x)) nil 'tensor-dimension-mismatch) (if (null dims) - (setf dims (copy-seq xdims)) - (loop :for i :from 0 :below (length dims) - :do (if (/= i axis) - (assert (= (aref xdims i) (aref dims i)) nil 'tensor-dimension-mismatch) - (setf (aref dims i) (min (aref xdims i) (aref dims i))))))) + (setf dims (aref xdims axis)) + (setf dims (min (aref xdims axis) dims)))) :collect (aref (strides x) axis) :into strides :collect (slice~ x axis) :into slices - :finally (return (values (aref dims axis) strides slices)))) + :finally (return (values dims strides slices)))) (defun mapslice (axis func tensor &rest more-tensors) (multiple-value-bind (d.axis strides slices) (check-dims axis (cons tensor more-tensors)) commit 56b707f789c453e157d0818fc8fcf0a16a699db8 Author: Akshay Srinivasan <aks...@gm...> Date: Thu Apr 10 14:25:38 2014 -0700 Fixes to tweaks to map.lisp. diff --git a/src/special/map.lisp b/src/special/map.lisp index 044e491..10de493 100644 --- a/src/special/map.lisp +++ b/src/special/map.lisp @@ -90,7 +90,7 @@ (multiple-value-bind (d.axis strides slices) (check-dims axis (cons tensor more-tensors)) (loop :for i :from 0 :below d.axis :collect (prog1 (apply func (mapcar #'copy slices)) - (unless (< i (1- d.axis)) + (when (< i (1- d.axis)) (loop :for slc :in slices :for std :in strides :do (incf (slot-value slc 'head) std))))))) @@ -99,7 +99,7 @@ (multiple-value-bind (d.axis strides slices) (check-dims axis (cons tensor more-tensors)) (loop :for i :from 0 :below d.axis :collect (prog1 (apply func slices) - (unless (< i (1- d.axis)) + (when (< i (1- d.axis)) (loop :for slc :in slices :for std :in strides :do (incf (slot-value slc 'head) std))))))) @@ -108,7 +108,7 @@ (multiple-value-bind (d.axis strides slices) (check-dims axis (cons tensor more-tensors)) (loop :for i :from 0 :below d.axis :do (prog1 (apply func slices) - (unless (< i (1- d.axis)) + (when (< i (1- d.axis)) (loop :for slc :in slices :for std :in strides :do (incf (slot-value slc 'head) std)))))) commit 3caa822f9516b69bc5aba4bd2cb840a05b09e48b Author: Akshay Srinivasan <aks...@gm...> Date: Thu Apr 10 14:21:00 2014 -0700 Tweaks to map.lisp diff --git a/src/reader/loadsave.lisp b/src/reader/loadsave.lisp index 92ba338..ba37f29 100644 --- a/src/reader/loadsave.lisp +++ b/src/reader/loadsave.lisp @@ -12,9 +12,10 @@ (let* ((f-string (file->string fname)) (*read-default-float-format* 'double-float)) (multiple-value-bind (lns nrows) (split-seq #'(lambda (x) (member x newlines)) f-string) - (incf nrows) + (setf nrows (+ nrows 1 (- skip-rows)) + lns (nthcdr skip-rows lns)) (unless (null lns) - (let* ((ncols (1+ (nth-value 1(split-seq #'(lambda (x) (member x delimiters)) (car lns))))) + (let* ((ncols (1+ (nth-value 1 (split-seq #'(lambda (x) (member x delimiters)) (car lns))))) (ret (zeros (if (> ncols 1) (list nrows ncols) (list nrows)) 'real-tensor))) (if (> ncols 1) (loop :for line :in lns @@ -68,7 +69,7 @@ ((null line) mtx) (let ((dat (mapcar #'read-from-string (split-seq #'(lambda (x) (member x delimiters)) line)))) (setf (ref mtx (mapcar #'1- (subseq dat 0 2))) (third dat))))))) - + ;; (multiple-value-bind (lns nrows) (split-seq #'(lambda (x) (member x newlines)) f-string) ;; (loop :for ;; (unless (null lns) diff --git a/src/special/map.lisp b/src/special/map.lisp index 99524eb..044e491 100644 --- a/src/special/map.lisp +++ b/src/special/map.lisp @@ -90,25 +90,28 @@ (multiple-value-bind (d.axis strides slices) (check-dims axis (cons tensor more-tensors)) (loop :for i :from 0 :below d.axis :collect (prog1 (apply func (mapcar #'copy slices)) - (loop :for slc :in slices - :for std :in strides - :do (incf (slot-value slc 'head) std)))))) + (unless (< i (1- d.axis)) + (loop :for slc :in slices + :for std :in strides + :do (incf (slot-value slc 'head) std))))))) (defun mapslice~ (axis func tensor &rest more-tensors) (multiple-value-bind (d.axis strides slices) (check-dims axis (cons tensor more-tensors)) (loop :for i :from 0 :below d.axis :collect (prog1 (apply func slices) - (loop :for slc :in slices - :for std :in strides - :do (incf (slot-value slc 'head) std)))))) + (unless (< i (1- d.axis)) + (loop :for slc :in slices + :for std :in strides + :do (incf (slot-value slc 'head) std))))))) (defun mapslicec~ (axis func tensor &rest more-tensors) (multiple-value-bind (d.axis strides slices) (check-dims axis (cons tensor more-tensors)) (loop :for i :from 0 :below d.axis :do (prog1 (apply func slices) - (loop :for slc :in slices - :for std :in strides - :do (incf (slot-value slc 'head) std))))) + (unless (< i (1- d.axis)) + (loop :for slc :in slices + :for std :in strides + :do (incf (slot-value slc 'head) std)))))) (values-list (cons tensor more-tensors))) ;; commit 3afe61642a8951b86133c79e1fbd19839f48b8b8 Author: Akshay Srinivasan <aks...@gm...> Date: Wed Apr 9 16:03:43 2014 -0700 Added suptensor~ method. diff --git a/src/base/base-tensor.lisp b/src/base/base-tensor.lisp index 70f01fa..f0d8f99 100644 --- a/src/base/base-tensor.lisp +++ b/src/base/base-tensor.lisp @@ -288,6 +288,12 @@ (definline col-slice~ (x idx) (slice~ x 1 idx)) ;; +(defgeneric suptensor~ (tensor ord &optional start) + (:method :before ((tensor base-tensor) ord &optional start) + (let ((tord (order tensor))) + (assert (and (<= tord ord) (or (not (integerp start)) (>= (- ord tord start) 0))) nil 'invalid-arguments)))) + +;; (defun tensor-typep (tensor subs) " Syntax diff --git a/src/base/standard-tensor.lisp b/src/base/standard-tensor.lisp index 76f92fd..82f9eaa 100644 --- a/src/base/standard-tensor.lisp +++ b/src/base/standard-tensor.lisp @@ -186,3 +186,23 @@ :store (store tensor) :parent-tensor tensor)) (store-ref tensor hd))))) + +(defmethod suptensor~ ((ten standard-tensor) ord &optional start) + (if (= (order ten) ord) + ten + (let ((tord (order ten))) + (unless (integerp start) + (setq start (if start (- ord tord) 0))) + (let ((stds (make-index-store (append (make-list start :initial-element 1) + (lvec->list (strides ten)) + (make-list (- ord tord start) :initial-element 1)))) + (dims (make-index-store (append (make-list start :initial-element 1) + (dims ten) + (make-list (- ord tord start) :initial-element 1))))) + (with-no-init-checks + (make-instance (class-of ten) + :dimensions dims + :strides stds + :head (head ten) + :store (store ten) + :parent-tensor ten)))))) commit 0d327c3a710ab3bce416b0ac48093557e073e6b4 Author: Akshay Srinivasan <aks...@gm...> Date: Mon Apr 7 22:33:35 2014 -0700 Added optimized methods for max,min. diff --git a/src/special/norm.lisp b/src/special/norm.lisp index 4d66e05..2ce9a29 100644 --- a/src/special/norm.lisp +++ b/src/special/norm.lisp @@ -12,37 +12,46 @@ ((eql n :sup) (tensor-foldl ,(cl vec) max vec (t/fid+ ,(field-type (cl vec))) :key abs)))) -;;It's fairly simple to write optimized versions. Optimize at your own discretion. -;; (defun tomax (vec) -;; (declare (type real-tensor vec)) -;; (let-typed ((max 0d0 :type double-float)) -;; (very-quickly -;; (dorefs (idx (dimensions vec)) -;; ((rvec vec :type real-tensor)) -;; (let-typed ((r rvec :type double-float)) -;; (when (> r max) -;; (setf max r))))) -;; max)) (defgeneric tensor-max (vec &optional key)) -(define-tensor-method tensor-max ((vec standard-tensor :input) &optional (key #'id)) - `(let* ((max-idx (make-list (order vec) :initial-element 0)) - (max (funcall key (ref vec max-idx)))) - (dorefs (idx (dimensions vec)) - ((ref vec :type ,(cl vec))) - (let ((kval (funcall key ref))) - (when (> kval max) - (setf max kval) - (lvec->list! idx max-idx)))) - (values max max-idx))) +(define-tensor-method tensor-max ((vec standard-tensor :input) &optional key) + `(if key + (let* ((ridx (make-list (order vec) :initial-element 0)) + (rval (funcall key (ref vec ridx)))) + (dorefs (idx (dimensions vec)) + ((ref vec :type ,(cl vec))) + (let ((kval (funcall key ref))) + (when (> kval rval) + (setf rval kval) + (lvec->list! idx ridx)))) + (values rval ridx)) + (let*-typed ((ridx (make-list (order vec) :initial-element 0)) + (rval (ref vec ridx) :type ,(field-type (cl vec)))) + (dorefs (idx (dimensions vec)) + ((ref vec :type ,(cl vec))) + (let-typed ((r ref :type ,(field-type (cl vec)))) + (when (> r rval) + (setf rval r) + (lvec->list! idx ridx)))) + (values rval ridx)))) (defgeneric tensor-min (vec &optional key)) -(define-tensor-method tensor-min ((vec standard-tensor :input) &optional (key #'id)) - `(let* ((min-idx (make-list (order vec) :initial-element 0)) - (min (funcall key (ref vec min-idx)))) - (dorefs (idx (dimensions vec)) - ((ref vec :type ,(cl vec))) - (let ((kval (funcall key ref))) - (when (< kval min) - (setf min kval) - (lvec->list! idx min-idx)))) - (values min min-idx))) +(define-tensor-method tensor-min ((vec standard-tensor :input) &optional key) + `(if key + (let* ((ridx (make-list (order vec) :initial-element 0)) + (rval (funcall key (ref vec ridx)))) + (dorefs (idx (dimensions vec)) + ((ref vec :type ,(cl vec))) + (let ((kval (funcall key ref))) + (when (< kval rval) + (setf rval kval) + (lvec->list! idx ridx)))) + (values rval ridx)) + (let*-typed ((ridx (make-list (order vec) :initial-element 0)) + (rval (ref vec ridx) :type ,(field-type (cl vec)))) + (dorefs (idx (dimensions vec)) + ((ref vec :type ,(cl vec))) + (let-typed ((r ref :type ,(field-type (cl vec)))) + (when (< r rval) + (setf rval r) + (lvec->list! idx ridx)))) + (values rval ridx)))) commit f907ad7cfb43867bce9af5226162e4d9509d9a00 Author: Akshay Srinivasan <aks...@gm...> Date: Mon Apr 7 22:23:36 2014 -0700 Added max,min methods. diff --git a/src/special/norm.lisp b/src/special/norm.lisp index d4736a9..4d66e05 100644 --- a/src/special/norm.lisp +++ b/src/special/norm.lisp @@ -1,13 +1,48 @@ (in-package :matlisp) -(defun norm (vec &optional (n 2)) - (declare (type real-tensor vec)) - (cond - ((typep n 'real) - (let-typed ((sum 0d0 :type double-float)) - (dorefs (idx (dimensions vec)) - ((ref vec :type real-tensor)) - (incf sum (expt (abs ref) n))) - (expt sum (/ 1 n)))) - ((eql n :sup) - (tensor-foldl real-tensor max vec 0d0)))) +(defgeneric norm (vec &optional n)) +(define-tensor-method norm ((vec numeric-tensor :input) &optional (n 2)) + `(cond + ((typep n 'real) + (let-typed ((sum (t/fid+ ,(field-type (cl vec))) :type ,(field-type (cl vec)))) + (dorefs (idx (dimensions vec)) + ((ref vec :type ,(cl vec))) + (setf sum (t/f+ ,(field-type (cl vec)) sum (expt (abs ref) n)))) + (expt sum (/ n)))) + ((eql n :sup) + (tensor-foldl ,(cl vec) max vec (t/fid+ ,(field-type (cl vec))) :key abs)))) + +;;It's fairly simple to write optimized versions. Optimize at your own discretion. +;; (defun tomax (vec) +;; (declare (type real-tensor vec)) +;; (let-typed ((max 0d0 :type double-float)) +;; (very-quickly +;; (dorefs (idx (dimensions vec)) +;; ((rvec vec :type real-tensor)) +;; (let-typed ((r rvec :type double-float)) +;; (when (> r max) +;; (setf max r))))) +;; max)) +(defgeneric tensor-max (vec &optional key)) +(define-tensor-method tensor-max ((vec standard-tensor :input) &optional (key #'id)) + `(let* ((max-idx (make-list (order vec) :initial-element 0)) + (max (funcall key (ref vec max-idx)))) + (dorefs (idx (dimensions vec)) + ((ref vec :type ,(cl vec))) + (let ((kval (funcall key ref))) + (when (> kval max) + (setf max kval) + (lvec->list! idx max-idx)))) + (values max max-idx))) + +(defgeneric tensor-min (vec &optional key)) +(define-tensor-method tensor-min ((vec standard-tensor :input) &optional (key #'id)) + `(let* ((min-idx (make-list (order vec) :initial-element 0)) + (min (funcall key (ref vec min-idx)))) + (dorefs (idx (dimensions vec)) + ((ref vec :type ,(cl vec))) + (let ((kval (funcall key ref))) + (when (< kval min) + (setf min kval) + (lvec->list! idx min-idx)))) + (values min min-idx))) commit abb0a6f58d54ca9629afef9e56afbc41041ebb14 Author: Akshay Srinivasan <aks...@gm...> Date: Mon Apr 7 21:40:33 2014 -0700 Added norm.lisp. diff --git a/matlisp.asd b/matlisp.asd index 0f12aa4..f6bccd0 100644 --- a/matlisp.asd +++ b/matlisp.asd @@ -178,6 +178,7 @@ :depends-on ("matlisp-base" "matlisp-classes" "matlisp-blas") :components ((:file "random") (:file "map") + (:file "norm") (:file "seq"))) (:module "matlisp-sugar" :pathname "sugar" diff --git a/src/special/norm.lisp b/src/special/norm.lisp new file mode 100644 index 0000000..d4736a9 --- /dev/null +++ b/src/special/norm.lisp @@ -0,0 +1,13 @@ +(in-package :matlisp) + +(defun norm (vec &optional (n 2)) + (declare (type real-tensor vec)) + (cond + ((typep n 'real) + (let-typed ((sum 0d0 :type double-float)) + (dorefs (idx (dimensions vec)) + ((ref vec :type real-tensor)) + (incf sum (expt (abs ref) n))) + (expt sum (/ 1 n)))) + ((eql n :sup) + (tensor-foldl real-tensor max vec 0d0)))) commit bd8ba7b1d0ba2971f28a1690fdea106397a90d04 Author: Akshay Srinivasan <aks...@gm...> Date: Sat Apr 5 18:25:34 2014 -0700 Saving changes for working with negative indices. diff --git a/src/base/blas-helpers.lisp b/src/base/blas-helpers.lisp index 03fb327..d667bf3 100644 --- a/src/base/blas-helpers.lisp +++ b/src/base/blas-helpers.lisp @@ -51,8 +51,8 @@ (cond ;;The ordering of these conditions is important to meet certain assumed conditions ;;in GEMM, when MATRIX has strides of the form #(1 1). - ((= rs 1) (values cs op :col-major)) - ((and (char/= op #\C) (= cs 1)) (values rs (fortran-nop op) :row-major))))) + ((and (= rs 1) (> cs 0)) (values cs op :col-major)) + ((and (char/= op #\C) (= cs 1) (> rs 0)) (values rs (fortran-nop op) :row-major))))) (definline call-fortran? ( x lb) (declare (type standard-tensor x)) diff --git a/src/base/coordinate-sparse.lisp b/src/base/coordinate-sparse.lisp index 28f9fab..12bdfa9 100644 --- a/src/base/coordinate-sparse.lisp +++ b/src/base/coordinate-sparse.lisp @@ -7,6 +7,23 @@ (strides :initarg :strides :reader strides :type index-store-vector :documentation "Strides for accesing elements of the tensor."))) +(defmethod initialize-instance :after ((tensor coordinate-sparse-tensor) &rest initargs) + (declare (ignore initargs)) + (when *check-after-initializing?* + (let-typed ((dims (dimensions tensor) :type index-store-vector)) + (assert (>= (head tensor) 0) nil 'tensor-invalid-head-value :head (head tensor) :tensor tensor) + (if (not (slot-boundp tensor 'strides)) + (setf (slot-value tensor 'strides) (make-stride-cmj dims)) + (very-quickly + (let-typed ((stds (strides tensor) :type index-store-vector)) + (loop :for i :of-type index-type :from 0 :below (order tensor) + :for sz :of-type index-type := (aref dims 0) :then (the index-type (* sz (aref dims i))) + :for lidx :of-type index-type := (the index-type (* (aref stds 0) (1- (aref dims 0)))) :then (the index-type (+ lidx (the index-type (* (aref stds i) (1- (aref dims i)))))) + :do (progn + (assert (> (aref stds i) 0) nil 'tensor-invalid-stride-value :argument i :stride (aref stds i) :tensor tensor) + (assert (> (aref dims i) 0) nil 'tensor-invalid-dimension-value :argument i :dimension (aref dims i) :tensor tensor)) + :finally (assert (>= (the index-type (store-size tensor)) (the index-type (+ (the index-type (head tensor)) lidx))) nil 'tensor-insufficient-store :store-size (store-size tensor) :max-idx lidx :tensor tensor)))))))) + (deft/generic (t/sparse-fill #'subtypep) sym ()) (deft/method t/sparse-fill (sym sparse-tensor) () `(t/fid+ (t/field-type ,sym))) diff --git a/src/base/standard-tensor.lisp b/src/base/standard-tensor.lisp index 2d092b3..76f92fd 100644 --- a/src/base/standard-tensor.lisp +++ b/src/base/standard-tensor.lisp @@ -37,10 +37,12 @@ (loop :for i :of-type index-type :from 0 :below rank :for cidx :across idx + :for d :across dims + :for s :across strides :with sto-idx :of-type index-type := hd :do (progn - (assert (< -1 cidx (aref dims i)) nil 'tensor-index-out-of-bounds :argument i :index cidx :dimension (aref dims i)) - (incf sto-idx (the index-type (* (aref strides i) cidx)))) + (assert (< (1- (- d)) cidx d) nil 'tensor-index-out-of-bounds :argument i :index cidx :dimension d) + (incf sto-idx (the index-type (* s (if (< cidx 0) (mod cidx d) cidx))))) :finally (return sto-idx))))) (defun store-indexing-lst (idx hd strides dims) @@ -64,14 +66,15 @@ (type index-store-vector strides dims) (type cons idx)) (let-typed ((rank (length strides) :type index-type)) - (assert (= rank (length dims)) nil 'tensor-dimension-mismatch) (very-quickly (loop :for cidx :of-type index-type :in idx :for i :of-type index-type := 0 :then (1+ i) + :for d :across dims + :for s :across strides :with sto-idx :of-type index-type := hd :do (progn - (assert (< -1 cidx (aref dims i)) nil 'tensor-index-out-of-bounds :argument i :index cidx :dimension (aref dims i)) - (incf sto-idx (the index-type (* (aref strides i) cidx)))) + (assert (< (1- (- d)) cidx d) nil 'tensor-index-out-of-bounds :argument i :index cidx :dimension d) + (incf sto-idx (the index-type (* s (if (< cidx 0) (mod cidx d) cidx))))) :finally (progn (assert (= (1+ i) rank) nil 'tensor-index-rank-mismatch :index-rank (1+ i) :rank rank) (return sto-idx)))))) @@ -144,11 +147,9 @@ (let-typed ((stds (strides tensor) :type index-store-vector)) (loop :for i :of-type index-type :from 0 :below (order tensor) :for sz :of-type index-type := (aref dims 0) :then (the index-type (* sz (aref dims i))) - :for lidx :of-type index-type := (the index-type (* (aref stds 0) (1- (aref dims 0)))) :then (the index-type (+ lidx (the index-type (* (aref stds i) (1- (aref dims i)))))) - :do (progn - (assert (> (aref stds i) 0) nil 'tensor-invalid-stride-value :argument i :stride (aref stds i) :tensor tensor) - (assert (> (aref dims i) 0) nil 'tensor-invalid-dimension-value :argument i :dimension (aref dims i) :tensor tensor)) - :finally (assert (>= (the index-type (store-size tensor)) (the index-type (+ (the index-type (head tensor)) lidx))) nil 'tensor-insufficient-store :store-size (store-size tensor) :max-idx lidx :tensor tensor)))))))) + :summing (the index-type (the index-type (* (aref stds i) (1- (aref dims i))))) :into lidx :of-type index-type + :do (assert (> (aref dims i) 0) nil 'tensor-invalid-dimension-value :argument i :dimension (aref dims i) :tensor tensor) + :finally (assert (>= (the index-type (store-size tensor)) (the index-type (+ (the index-type (head tensor)) lidx)) 0) nil 'tensor-insufficient-store :store-size (store-size tensor) :max-idx (the index-type (+ (head tensor) lidx)) :tensor tensor)))))))) (defmethod ref ((tensor standard-tensor) &rest subscripts) (let ((clname (class-name (class-of tensor)))) diff --git a/src/blas/copy.lisp b/src/blas/copy.lisp index 0d140e6..29b2c73 100644 --- a/src/blas/copy.lisp +++ b/src/blas/copy.lisp @@ -102,6 +102,77 @@ ,y)))) ;; +;;(t/copy! (real-coordinate-sparse-tensor real-compressed-sparse-matrix) x y) +(deft/method t/copy! ((clx coordinate-sparse-tensor) (cly compressed-sparse-matrix)) (x y) + (using-gensyms (decl (x y) (rstd cstd rdat key value r c s? v vi vr vd i col-stop row)) + `(let (,@decl) + (declare (type ,clx ,x) (type ,cly ,y)) + (let ((,cstd (aref (strides ,x) 1)) + (,rstd (aref (strides ,x) 0)) + (,rdat (make-array (if (transpose? ,y) (nrows ,x) (ncols ,x)) :initial-element nil))) + (if (transpose? ,y) + (loop :for ,key :being :the :hash-keys :of (store ,x) + :using (hash-value ,value) + :do (multiple-value-bind (,c ,r) (floor (the index-type ,key) ,cstd) + (multiple-value-bind (,r ,s?) (floor (the index-type ,r) ,rstd) + (when (zerop ,s?) + (push (cons ,c (t/coerce ,(field-type cly) ,value)) (aref ,rdat ,r)))))) + (loop :for ,key :being :the :hash-keys :of (store ,x) + :using (hash-value ,value) + :do (multiple-value-bind (,c ,r) (floor (the index-type ,key) ,cstd) + (multiple-value-bind (,r ,s?) (floor (the index-type ,r) ,rstd) + (when (zerop ,s?) + (push (cons ,r (t/coerce ,(field-type cly) ,value)) (aref ,rdat ,c))))))) + (let-typed ((,vi (neighbour-start ,y) :type index-store-vector) + (,vr (neighbour-id ,y) :type index-store-vector) + (,vd (store ,y) :type ,(store-type cly))) + (setf (aref ,vi 0) 0) + (very-quickly + (loop :for ,i :from 0 :below (ncols ,x) + :with ,col-stop := 0 + :do (let ((,row (sort (aref ,rdat ,i) #'(lambda (x y) (< (the index-type x) (the index-type y))) :key #'car))) + (loop :for (,r . ,v) :in ,row + :do (locally + (declare (type ,(field-type cly) ,v) + (type index-type ,r)) + (setf (aref ,vr ,col-stop) ,r) + (t/store-set real-compressed-sparse-matrix ,v ,vd ,col-stop) + (incf ,col-stop))) + (setf (aref ,vi (1+ ,i)) ,col-stop))))) + ,y)))) + +;; (deft/method t/copy! ((clx compressed-sparse-matrix) (cly coordinate-sparse-tensor)) (x y) +;; (using-gensyms (decl (x y) (cstd rdat key value r c v vi vr vd i col-stop row)) +;; `(let (,@decl) +;; (declare (type ,clx ,x) (type ,cly ,y)) +;; (let-typed ((,vi (neighbour-start ,x) :type index-store-vector) +;; (,vr (neighbour-id ,x) :type index-store-vector) +;; (,vd (store ,x) :type ,(store-type cly))) +;; (loop :for i :from 0 :below (1- (length ,vi)) +;; :do (loop :for j :from (aref ,vi i) :below (aref ,vi (1+ i)) +;; :do (setf + +;; (let ((,cstd (aref (strides ,x) 1)) +;; (,rdat (make-array (ncols ,x) :initial-element nil))) +;; (loop :for ,key :being :the :hash-keys :of (store ,x) +;; :using (hash-value ,value) +;; :do (multiple-value-bind (,c ,r) (floor (the index-type ,key) ,cstd) +;; (push (cons ,r (t/coerce ,(field-type cly) ,value)) (aref ,rdat ,c)))) +;; (setf (aref ,vi 0) 0) +;; (very-quickly +;; (loop :for ,i :from 0 :below (ncols ,x) +;; :with ,col-stop := 0 +;; :do (let ((,row (sort (aref ,rdat ,i) #'(lambda (x y) (< (the index-type x) (the index-type y))) :key #'car))) +;; (loop :for (,r . ,v) :in ,row +;; :do (locally +;; (declare (type ,(field-type cly) ,v) +;; (type index-type ,r)) +;; (setf (aref ,vr ,col-stop) ,r) +;; (t/store-set real-compressed-sparse-matrix ,v ,vd ,col-stop) +;; (incf ,col-stop))) +;; (setf (aref ,vi (1+ ,i)) ,col-stop))))) +;; ,y)))) +;; (deft/method t/copy! ((clx t) (cly standard-tensor)) (x y) (using-gensyms (decl (x y)) (with-gensyms (sto-y of-y idx cx) diff --git a/src/reader/infix.lisp b/src/reader/infix.lisp index 790fd10..4e55df6 100644 --- a/src/reader/infix.lisp +++ b/src/reader/infix.lisp @@ -40,7 +40,7 @@ (find operator *right-associative-operators*)) ;; Matlisp helpers -(defparameter *ref-list* '((cons elt) (array aref) (matlisp::base-tensor matlisp:ref))) +(defparameter *ref-list* '((cons elt) (array aref) (matlisp::base-tensor matlisp:ref) )) (defun process-slice (args) (mapcar #'(lambda (x) @@ -49,7 +49,7 @@ (if (eql (car x) ':slice) `(list* ,@(cdr x)) (with-gensyms (idx) - `(let ((,idx ,x)) (declare (type matlisp::index-type ,idx)) (list ,idx (1+ ,idx)))))) + `(let ((,idx ,x)) (declare (type matlisp::index-type ,idx)) (list ,idx (unless (= ,idx -1) (1+ ,idx))))))) ((or (numberp x) (symbolp x)) `(list ,x (1+ ,x))) (t (error 'parser-error :arguments x :message "unknown argument type")))) args)) @@ -233,17 +233,18 @@ nil)))))))));; and return nil (defun valid-numberp (string) - (with-readtable (:common-lisp) - (realp (read-from-string string)))) - ;; (let ((saw-dot nil)) - ;; (when (> (length string) 0) - ;; (dolist (char (coerce string 'list) t) - ;; (cond ((char= char #\.) - ;; (if saw-dot - ;; (return nil) - ;; (setq saw-dot t))) - ;; ((not (find char "01234567890" :test #'char=)) - ;; (return nil))))))) + (when (stringp string) + (with-readtable (:common-lisp) + (realp (read-from-string string nil nil))))) +;; (let ((saw-dot nil)) +;; (when (> (length string) 0) +;; (dolist (char (coerce string 'list) t) +;; (cond ((char= char #\.) +;; (if saw-dot +;; (return nil) +;; (setq saw-dot t))) +;; ((not (find char "01234567890" :test #'char=)) +;; (return nil))))))) ;;; Gobbles an expression from the stream. (defun gather-superiors (previous-operator stream) commit e4f79071c3818c46ee389c04e01cc086497966e9 Author: Akshay Srinivasan <aks...@gm...> Date: Thu Apr 3 19:12:13 2014 -0700 Fixed a silly bug in the parse-slice functions. diff --git a/src/base/base-tensor.lisp b/src/base/base-tensor.lisp index 9ce80a9..70f01fa 100644 --- a/src/base/base-tensor.lisp +++ b/src/base/base-tensor.lisp @@ -250,7 +250,7 @@ (end (proj end (if (> inc 0) d -1) d))) (declare (type index-type start end inc)) (let ((nd (ceiling (- end start) inc))) - (when (< nd 0) (return nil)) + (when (<= nd 0) (return nil)) (collect nd into dims) (collect (list* start end inc) into psubs)) (finally (return (values psubs dims)))))) @@ -268,7 +268,7 @@ (end (proj end (if (> inc 0) d -1) d))) (declare (type index-type start end inc)) (let ((nd (ceiling (- end start) inc))) - (when (< nd 0) (return (values -1 nil nil))) + (when (<= nd 0) (return (values -1 nil nil))) (incf hd (* s start)) (when (or preserve-rank (> nd 1)) (collect nd into dims) commit 5e67db6057fd19bc32ff2391f2e2a1aa278448b5 Author: Aksh... [truncated message content] |
From: Akshay S. <ak...@us...> - 2014-03-07 08:53:18
|
This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "matlisp". The branch, tensor has been updated via 6cfc62a0b8737f16a23c7c971cd5055fefb42750 (commit) via f3b37d1e92b7ee9cf9b508bd98df20df304bb958 (commit) via f235ae0cca3dc81ef9fabf2a35681ffed8505c79 (commit) via f82f9f87566e7359d0ad758dc61dc070cb29a3b0 (commit) via 03a936712182f839eec89db4ba08f0708af98dca (commit) via 6b070ed0049cd5271379c18e7a08e6f222d3b015 (commit) via 749437c8bb376d094b604c6977a7e7c037a522a0 (commit) via 8aebe561eef23310bcbb1cb2f93518a68f454231 (commit) via 9a4472e4325ca93c9bdbddfedf28de9ee724b6cc (commit) via ae2c399227295cf632250d8ba6b0ddeb984d0cae (commit) via 1f0deb99d702dee0b93e3defe2404b307c7b3530 (commit) from f38e6dde50fbe1552793f8146fa42734d522e9c9 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 6cfc62a0b8737f16a23c7c971cd5055fefb42750 Author: Akshay Srinivasan <aks...@gm...> Date: Fri Mar 7 00:53:06 2014 -0800 Removed whitespace in compressed sparse. diff --git a/src/base/compressed-sparse.lisp b/src/base/compressed-sparse.lisp index 0f7db62..315a943 100644 --- a/src/base/compressed-sparse.lisp +++ b/src/base/compressed-sparse.lisp @@ -133,7 +133,7 @@ :do (setf (aref ni i) r (aref vi i) v)))) (t/store-set ,clname value (store tensor) idx)) - (when (>= idx 0) + (when (>= idx 0) (let ((ns (neighbour-start tensor)) (ni (neighbour-id tensor)) (vi (store tensor))) @@ -145,5 +145,5 @@ (aref vi i) (aref vi (1+ i)))) (loop :for i :from (1+ col) :below (length ns) :do (decf (aref ns i))))))) - value)))) + value)))) (setf (ref tensor (if (numberp (car subscripts)) subscripts (car subscripts))) value))) commit f3b37d1e92b7ee9cf9b508bd98df20df304bb958 Author: Akshay Srinivasan <aks...@gm...> Date: Fri Mar 7 00:50:40 2014 -0800 Added a ref method for compressed sparse matrices. diff --git a/src/base/compressed-sparse.lisp b/src/base/compressed-sparse.lisp index c4eb11e..0f7db62 100644 --- a/src/base/compressed-sparse.lisp +++ b/src/base/compressed-sparse.lisp @@ -30,7 +30,7 @@ (lb (aref nst col) :type index-type) (ub (aref nst (1+ col)) :type index-type)) (declare (type index-type row col)) - (if (or (= lb ub) (< row (aref nid lb)) (> row (aref nid (1- ub)))) -1 + (if (or (= lb ub) (< row (aref nid lb)) (> row (aref nid (1- ub)))) (values -1 row col) (values (very-quickly (loop :with j := (ash (+ lb ub) -1) @@ -87,28 +87,63 @@ (t/store-ref ,clname (store tensor) idx))))) (apply #'ref (cons tensor subscripts)))) -;; (defmethod (setf ref) (value (tensor compressed-sparse-matrix) &rest subscripts) -;; (let ((clname (class-name (class-of tensor)))) -;; (assert (member clname *tensor-type-leaves*) nil 'tensor-abstract-class :tensor-class clname) -;; (compile-and-eval -;; `(defmethod (setf ref) (value (tensor ,clname) &rest subscripts) -;; (multiple-value-bind (idx row col) (compressed-sparse-indexing (if (numberp (car subscripts)) subscripts (car subscripts)) tensor) -;; (if (< idx 0) -;; (let ((ns (neighbour-start tensor)) -;; (ni (neighbour-id tensor)) -;; (vi (store tensor))) -;; (unless (> (store-size tensor) (aref ns (1- (length ns)))) -;; (let ((sto-new (make-a-bigger-array))) -;; (move-things forward) -;; copy-back-to-vi..)) -;; (let ((row-data (merge 'list -;; (cons row (t/coerce ,(field-type clname) value)) -;; (loop :for j :from (aref ns col) :to (aref ns (1+ col)) -;; :collect (cons (aref ni j) (aref vi j))) -;; #'< :key #'car))) - - -;; ) -;; (t/store-set ,clname (t/coerce ,(field-type clname) value) (store tensor) idx))))) -;; (setf (ref tensor (if (numberp (car subscripts)) subscripts (car subscripts))) value))) -;; +(defmethod (setf ref) (value (tensor compressed-sparse-matrix) &rest subscripts) + (let ((clname (class-name (class-of tensor)))) + (assert (member clname *tensor-type-leaves*) nil 'tensor-abstract-class :tensor-class clname) + (compile-and-eval + `(defmethod (setf ref) (value (tensor ,clname) &rest subscripts) + (multiple-value-bind (idx row col) (compressed-sparse-indexing (if (numberp (car subscripts)) subscripts (car subscripts)) tensor) + (declare (type index-type idx row col)) + (let-typed ((value (t/coerce ,(field-type clname) value) :type ,(field-type clname))) + (if (/= value (t/fid+ ,(field-type clname))) + (if (< idx 0) + (let* ((ns (neighbour-start tensor)) + (value (t/coerce ,(field-type clname) value)) + (row-data (let ((ni (neighbour-id tensor)) + (vi (store tensor))) + (merge 'list + (list (cons row value)) + (loop :for j :from (aref ns col) :below (aref ns (1+ col)) + :collect (cons (aref ni j) (aref vi j))) + #'< :key #'car)))) + (unless (> (store-size tensor) (aref ns (1- (length ns)))) + (destructuring-bind (ni vi) (t/store-allocator ,clname (dims tensor) (+ (store-size tensor) *default-sparse-store-increment*)) + (let ((nio (neighbour-id tensor)) + (vio (store tensor))) + (very-quickly + (declare (type index-store-vector nio ni ns) + (type ,(store-type clname) vio vi)) + (loop :for i :from 0 :below (aref ns col) + :do (setf (aref nio i) (aref ni i) + (aref vio i) (aref vi i))) + (loop :for i :from (aref ns (1+ col)) :below (aref ns (1- (length ns))) + :do (setf (aref nio (1+ i)) (aref ni i) + (aref vio (1+ i)) (aref vi i)))) + (setf (slot-value tensor 'neighbour-id) ni + (slot-value tensor 'store) vi)))) + (let ((ni (neighbour-id tensor)) + (vi (store tensor))) + (very-quickly + (declare (type index-store-vector ni ns) + (type ,(store-type clname) vi)) + (loop :for i :from (1+ col) :below (length ns) + :do (incf (aref ns i)))) + (loop :for (r . v) :in row-data + :for i := (aref ns col) :then (1+ i) + :do (setf (aref ni i) r + (aref vi i) v)))) + (t/store-set ,clname value (store tensor) idx)) + (when (>= idx 0) + (let ((ns (neighbour-start tensor)) + (ni (neighbour-id tensor)) + (vi (store tensor))) + (very-quickly + (declare (type index-store-vector ns ni) + (type ,(store-type clname) vi)) + (loop :for i :from idx :below (aref ns (1- (length ns))) + :do (setf (aref ni i) (aref ni (1+ i)) + (aref vi i) (aref vi (1+ i)))) + (loop :for i :from (1+ col) :below (length ns) + :do (decf (aref ns i))))))) + value)))) + (setf (ref tensor (if (numberp (car subscripts)) subscripts (car subscripts))) value))) diff --git a/src/base/coordinate-sparse.lisp b/src/base/coordinate-sparse.lisp index af77ead..6f4b7f2 100644 --- a/src/base/coordinate-sparse.lisp +++ b/src/base/coordinate-sparse.lisp @@ -1,9 +1,6 @@ (in-package :matlisp) ;;One may to do better than a Hash-table for this. -(defparameter *default-sparsity* 1/1000) -(defparameter *max-sparse-size* 10000) - (defclass coordinate-sparse-tensor (sparse-tensor) ((strides :initarg :strides :reader strides :type index-store-vector :documentation "Strides for accesing elements of the tensor."))) diff --git a/src/base/tweakable.lisp b/src/base/tweakable.lisp index cab998f..32918db 100644 --- a/src/base/tweakable.lisp +++ b/src/base/tweakable.lisp @@ -6,6 +6,21 @@ ;;that you use lexical scoping to affect local changes to ;;code (global variables are only bad if you overwrite them :) +(defparameter *default-sparse-store-increment* 100 + " + Determines the increment by which the store of a compressed sparse matrix is increased, + when it runs out of store.") + +(defparameter *default-sparsity* 1/1000 + " + Determines the default sparsity for a newly created sparse matrix, when the number of non-zero is + not specified.") + +(defparameter *max-sparse-size* 10000 + " + Upper bounds the store size for a newly created sparse matrix, when the number of non-zero is + not specified.") + ;;Default ordering of strides (defparameter *default-stride-ordering* :col-major " commit f235ae0cca3dc81ef9fabf2a35681ffed8505c79 Author: Akshay Srinivasan <aks...@gm...> Date: Thu Mar 6 22:43:58 2014 -0800 Added "ignorable" declarations to deft/method; gets rid of all those annoying style warnings. diff --git a/src/utilities/template.lisp b/src/utilities/template.lisp index 4f40e41..d802043 100644 --- a/src/utilities/template.lisp +++ b/src/utilities/template.lisp @@ -115,12 +115,17 @@ (error "Undefined template : ~a~%" ',name))) (,meth-sym (getf ,data-sym :methods)) (,afun-sym (lambda (,(if single? disp-vars disp-sym) ,@args) - ,(recursive-append + (declare (ignorable ,@(remove-if #'(lambda (x) (char= #\& (aref (symbol-name x) 0))) + (mapcar #'(lambda (x) (if (consp x) (car x) x)) + (cons (if single? disp-vars disp-sym) args))))) + ,(recursive-append (unless single? - `(destructuring-bind (,@disp-vars) ,disp-sym)) + `(destructuring-bind (,@disp-vars) ,disp-sym + (declare (ignorable ,@disp-vars)))) `(progn ,@body)))) (,sort-sym (getf ,data-sym :sorter))) + (declare (ignorable ,data-sym ,meth-sym ,afun-sym ,sort-sym)) (setf ,meth-sym (topological-sort (setadd ,meth-sym (list ,afun-sym ',disp-spls) #'(lambda (a b) (list-eq (second a) (second b)))) #'(lambda (a b) (funcall ,sort-sym (second a) (second b))))) (setf (getf ,data-sym :methods) ,meth-sym) ,afun-sym))))) commit f82f9f87566e7359d0ad758dc61dc070cb29a3b0 Author: Akshay Srinivasan <aks...@gm...> Date: Thu Mar 6 22:14:19 2014 -0800 Switched from vanilla sort to topological sort to deal with the lack of total ordering on types. diff --git a/src/blas/copy.lisp b/src/blas/copy.lisp index 146e1b6..7b3a189 100644 --- a/src/blas/copy.lisp +++ b/src/blas/copy.lisp @@ -124,7 +124,7 @@ (assert (very-quickly (lvec-eq (the index-store-vector (dimensions x)) (the index-store-vector (dimensions y)) #'=)) nil 'tensor-dimension-mismatch)) -(defmethod :before copy! ((a sparse-tensor) (b sparse-tensor)) +(defmethod copy! :before ((a base-tensor) (b compressed-sparse-matrix)) (assert (< (store-size a) (store-size b)) nil 'tensor-insufficient-store)) (defmethod copy! ((x standard-tensor) (y standard-tensor)) diff --git a/src/utilities/template.lisp b/src/utilities/template.lisp index f11fe68..4f40e41 100644 --- a/src/utilities/template.lisp +++ b/src/utilities/template.lisp @@ -6,6 +6,37 @@ (defvar *template-table* (make-hash-table)) +(defun topological-sort (lst func &optional (test #'eql)) + (multiple-value-bind (nlst len) (loop :for ele :in lst + :for i := 0 :then (1+ i) + :collect (cons i ele) :into ret + :finally (return (values ret (1+ i)))) + (let* ((S nil) + (graph (let ((ret (make-array len))) + (loop :for (i . ele) :in nlst + :do (let ((children (mapcar #'car (remove-if-not #'(lambda (x) (and (not (funcall test (cdr x) ele)) (funcall func (cdr x) ele))) nlst))) + (parents (mapcar #'car (remove-if-not #'(lambda (x) (and (not (funcall test (cdr x) ele)) (funcall func ele (cdr x)))) nlst)))) + (when (null parents) + (push i S)) + (setf (aref ret i) (list ele children parents)))) + ret)) + (ordering nil)) + (let ((last-S (last S))) + (do ((slst S (cdr slst))) + ((null slst)) + (let* ((i (car slst)) + (children (second (aref graph i)))) + (mapcar #'(lambda (x) + (let ((par (third (aref graph x)))) + (let ((par (remove i par))) + (setf (third (aref graph x)) par) + (when (null par) + (setf (cdr last-S) (cons x nil) + last-S (cdr last-S)))))) + children) + (push i ordering)))) + (mapcar #'(lambda (x) (car (aref graph x))) ordering)))) + (defun match-lambda-lists (lsta lstb) (let ((optional? nil)) (labels ((optp? (a b) @@ -90,7 +121,7 @@ `(progn ,@body)))) (,sort-sym (getf ,data-sym :sorter))) - (setf ,meth-sym (sort (setadd ,meth-sym (list ,afun-sym ',disp-spls) #'(lambda (a b) (list-eq (second a) (second b)))) #'(lambda (a b) (funcall ,sort-sym (second a) (second b))))) + (setf ,meth-sym (topological-sort (setadd ,meth-sym (list ,afun-sym ',disp-spls) #'(lambda (a b) (list-eq (second a) (second b)))) #'(lambda (a b) (funcall ,sort-sym (second a) (second b))))) (setf (getf ,data-sym :methods) ,meth-sym) ,afun-sym))))) commit 03a936712182f839eec89db4ba08f0708af98dca Author: Akshay Srinivasan <aks...@gm...> Date: Tue Mar 4 02:13:21 2014 -0800 Saving state on the sparse tensor. diff --git a/matlisp.asd b/matlisp.asd index a356b04..92f4b31 100644 --- a/matlisp.asd +++ b/matlisp.asd @@ -126,12 +126,15 @@ (:file "blas-helpers" :depends-on ("standard-tensor" "permutation")) (:file "print" - :depends-on ("standard-tensor")))) + :depends-on ("base-tensor" "standard-tensor")) + (:file "coordinate-sparse") + (:file "compressed-sparse"))) (:module "matlisp-classes" :pathname "classes" :depends-on ("matlisp-base") :components ((:file "numeric") + (:file "sparse") #+maxima (:file "symbolic-tensor") (:file "matrix" diff --git a/src/base/compressed-sparse.lisp b/src/base/compressed-sparse.lisp index 85b65d3..c4eb11e 100644 --- a/src/base/compressed-sparse.lisp +++ b/src/base/compressed-sparse.lisp @@ -24,41 +24,41 @@ (setf row (the index-type (aref subs 0)) col (the index-type (aref subs 1))))) (when (transpose? tensor) - (rotatef row col)) - (let*-typed ((nst (neighbour-start tensor) :type index-store-vector) - (nid (neighbour-id tensor) :type index-store-vector) - (lb (aref nst col) :type index-type) - (ub (aref nst (1+ col)) :type index-type)) + (rotatef row col)) + (let*-typed ((nst (neighbour-start tensor) :type index-store-vector) + (nid (neighbour-id tensor) :type index-store-vector) + (lb (aref nst col) :type index-type) + (ub (aref nst (1+ col)) :type index-type)) (declare (type index-type row col)) (if (or (= lb ub) (< row (aref nid lb)) (> row (aref nid (1- ub)))) -1 - (very-quickly - (loop :with j := (ash (+ lb ub) -1) - :repeat 64 - :do (progn - #+nil(format t "~a, ~a, ~a~%" lb j ub) - (cond - ((= (aref nid j) row) (return j)) - ((>= lb (1- ub)) (return -1)) - (t - (if (< row (aref nid j)) - (setf ub j) - (setf lb (1+ j))) - (setf j (ash (+ lb ub) -1))))))))))) - -(deft/method t/store-allocator (sym compressed-sparse-matrix) (size &optional initial-element) - (let ((sto-type (store-element-type sym))) - (using-gensyms (decl (size)) - `(let (,@decl) - (destructuring-bind (ni nz) (t/compute-store-size ,sym ,size) - (list - (allocate-index-store (1+ ni)) - (allocate-index-store nz) - (make-array nz :element-type ',sto-type :initial-element ,(if (subtypep sto-type 'number) `(t/fid+ ,sto-type) nil)))))))) + (values + (very-quickly + (loop :with j := (ash (+ lb ub) -1) + :repeat 64 + :do (progn + #+nil(format t "~a, ~a, ~a~%" lb j ub) + (cond + ((= (aref nid j) row) (return j)) + ((>= lb (1- ub)) (return -1)) + (t + (if (< row (aref nid j)) + (setf ub j) + (setf lb (1+ j))) + (setf j (ash (+ lb ub) -1))))))) + row col))))) + +;;Templates +(deft/method t/store-allocator (cl compressed-sparse-matrix) (size &optional nz) + (let ((sto-type (store-element-type cl))) + `(destructuring-bind (nr nc) ,size + (let ((nz (or ,nz (min (ceiling (* nr nc *default-sparsity*)) *max-sparse-size*)))) + (list + (allocate-index-store nz) + (make-array (t/compute-store-size ,cl nz) :element-type ',sto-type :initial-element ,(if (subtypep sto-type 'number) `(t/fid+ ,sto-type) nil))))))) (deft/method t/compute-store-size (sym compressed-sparse-matrix) (size) - `(destructuring-bind (nr nc &optional nz) ,size - (list nc (or nz (min (ceiling (* nr nc *default-sparsity*)) *max-sparse-size*))))) - + size) +;; (deft/method t/store-type (sym compressed-sparse-matrix) (&optional (size '*)) `(simple-array ,(store-element-type sym) (,size))) @@ -66,122 +66,49 @@ (assert (null (cdr idx)) nil "given more than one index for compressed-store") `(aref (the ,(store-type sym) ,store) (the index-type ,(car idx)))) -(deft/method t/store-size (sym compressed-sparse-matrix) (ele) - `(length ,ele)) - -(deft/method t/store-element-type (sym compressed-sparse-matrix) () - (macroexpand `(t/field-type ,sym))) - -;; (deft/method t/store-set (sym compressed-sparse-matrix) (value store &rest idx) (assert (null (cdr idx)) nil "given more than one index for compressed store") `(setf (aref (the ,(store-type sym) ,store) (the index-type ,(car idx))) (the ,(field-type sym) ,value))) -;; (deft/method t/store-set (sym coordinate-sparse-tensor) (value store &rest idx) -;; (assert (null (cdr idx)) nil "given more than one index for hashtable.") -;; (with-gensyms (val) -;; `(let-typed ((,val ,value :type ,(field-type sym))) -;; (unless (t/f= ,(field-type sym) ,val (t/fid+ ,(field-type sym))) -;; (setf (gethash ,(car idx) ,store) (the ,(field-type sym) ,value)))))) +(deft/method t/store-size (sym compressed-sparse-matrix) (ele) + `(length ,ele)) +(deft/method t/store-element-type (sym compressed-sparse-matrix) () + (macroexpand `(t/field-type ,sym))) ;; (defmethod ref ((tensor compressed-sparse-matrix) &rest subscripts) (let ((clname (class-name (class-of tensor)))) (assert (member clname *tensor-type-leaves*) nil 'tensor-abstract-class :tensor-class clname) (compile-and-eval - `(defmethod ref ((tensor ,clname) &rest subscripts) + `(defmethod ref ((tensor ,clname) &rest subscripts) (let ((idx (compressed-sparse-indexing (if (numberp (car subscripts)) subscripts (car subscripts)) tensor))) (if (< idx 0) (t/sparse-fill ,clname) (t/store-ref ,clname (store tensor) idx))))) (apply #'ref (cons tensor subscripts)))) -#+nil -(defmethod (setf ref) (value (tensor compressed-sparse-matrix) &rest subscripts) - (let ((clname (class-name (class-of tensor)))) - (assert (member clname *tensor-type-leaves*) nil 'tensor-abstract-class :tensor-class clname) - (compile-and-eval - `(defmethod (setf ref) (value (tensor ,clname) &rest subscripts) - (let* ((subs (if (numberp (car subscripts)) subscripts (car subscripts))) - (idx (store-indexing subs tensor)) - (sto (store tensor))) - (t/store-set ,clname (t/coerce ,(field-type clname) value) sto idx) - (t/store-ref ,clname sto idx)))) - (setf (ref tensor (if (numberp (car subscripts)) subscripts (car subscripts))) value))) -;; -(defleaf real-compressed-sparse-matrix (compressed-sparse-matrix) ()) -(deft/method t/field-type (sym real-compressed-sparse-matrix) () - 'double-float) - +;; (defmethod (setf ref) (value (tensor compressed-sparse-matrix) &rest subscripts) +;; (let ((clname (class-name (class-of tensor)))) +;; (assert (member clname *tensor-type-leaves*) nil 'tensor-abstract-class :tensor-class clname) +;; (compile-and-eval +;; `(defmethod (setf ref) (value (tensor ,clname) &rest subscripts) +;; (multiple-value-bind (idx row col) (compressed-sparse-indexing (if (numberp (car subscripts)) subscripts (car subscripts)) tensor) +;; (if (< idx 0) +;; (let ((ns (neighbour-start tensor)) +;; (ni (neighbour-id tensor)) +;; (vi (store tensor))) +;; (unless (> (store-size tensor) (aref ns (1- (length ns)))) +;; (let ((sto-new (make-a-bigger-array))) +;; (move-things forward) +;; copy-back-to-vi..)) +;; (let ((row-data (merge 'list +;; (cons row (t/coerce ,(field-type clname) value)) +;; (loop :for j :from (aref ns col) :to (aref ns (1+ col)) +;; :collect (cons (aref ni j) (aref vi j))) +;; #'< :key #'car))) + + +;; ) +;; (t/store-set ,clname (t/coerce ,(field-type clname) value) (store tensor) idx))))) +;; (setf (ref tensor (if (numberp (car subscripts)) subscripts (car subscripts))) value))) ;; -(defmethod :before copy! ((a sparse-tensor) (b sparse-tensor)) - (assert (< (store-size a) (store-size b)) nil 'tensor-insufficient-store)) - -(deft/method t/zeros (class compressed-sparse-matrix) (dims &optional nz) - `(destructuring-bind (vi vr vd) (t/store-allocator ,class (append ,dims ,@(when nz `((list ,nz))))) - (make-instance ',class - :dimensions (make-index-store ,dims) - :neighbour-start vi - :neighbour-id vr - :store vd))) - -(defmethod copy! ((x coordinate-sparse-tensor) (y compressed-sparse-matrix)) - (let ((clx (class-name (class-of x))) - (cly (class-name (class-of y)))) - (assert (and (member clx *tensor-type-leaves*) - (member cly *tensor-type-leaves*)) - nil 'tensor-abstract-class :tensor-class (list clx cly)) - (compile-and-eval - `(defmethod copy! ((x ,clx) (y ,cly)) - (let-typed ((stds (strides x) :type index-store-vector)) - (assert (and (tensor-matrixp x) (= (aref stds 0) 1)) nil 'tensor-invalid-stride-value) - (let ((col-stride (aref stds 1)) - (row-data (make-array (ncols x) :initial-element nil))) - (very-quickly - (loop :for key :being :the :hash-keys :of (store x) - :using (hash-value value) - :do (multiple-value-bind (c r) (floor (the index-type key) col-stride) - (push (cons r value) (aref row-data c))))) - (let-typed ((vi (neighbour-start y) :type index-store-vector) - (vr (neighbour-id y) :type index-store-vector) - (vd (store y) :type ,(store-type cly))) - (setf (aref vi 0) 0) - (very-quickly - (loop :for i :from 0 :below (ncols x) - :with col-stop := 0 - :do (let ((rowd (sort (aref row-data i) #'(lambda (x y) (< (the index-type x) (the index-type y))) :key #'car))) - (loop :for (r . v) :in rowd - :do (locally - (declare (type ,(field-type clx) v)) - (setf (aref vr col-stop) r) - (t/store-set real-compressed-sparse-matrix (t/coerce ,(field-type cly) v) vd col-stop) - (incf col-stop))) - (setf (aref vi (1+ i)) col-stop))))) - y)))) - (copy! x y))) - -(defmethod copy-generic ((a sparse-tensor) (type (eql 'real-compressed-sparse-matrix))) - (let-typed ((stds (strides a) :type index-store-vector)) - (assert (and (tensor-matrixp a) (= (aref stds 0) 1)) nil 'tensor-not-matrix) - (let ((col-stride (aref stds 1)) - (row-data (make-array (ncols a) :initial-element nil))) - (loop :for key :being :the :hash-keys :of (store a) - :using (hash-value value) - :do (multiple-value-bind (c r) (floor key col-stride) - (push (cons r value) (aref row-data c)))) - (destructuring-bind (vi vr vd) (t/store-allocator real-compressed-sparse-matrix (append (dims a) (list (store-size a)))) - (setf (aref vi 0) 0) - (loop :for i :from 0 :below (ncols a) - :with col-stop := 0 - :do (let ((rowd (sort (aref row-data i) #'< :key #'car))) - (loop :for (r . v) :in rowd - :do (progn - (setf (aref vr col-stop) r - (aref vd col-stop) v) - (incf col-stop))) - (setf (aref vi (1+ i)) col-stop))) - (make-instance 'real-compressed-sparse-matrix - :dimensions (copy-seq (dimensions a)) - :neighbour-start vi - :neighbour-id vr - :store vd))))) diff --git a/src/base/coordinate-sparse.lisp b/src/base/coordinate-sparse.lisp index 2365eb0..af77ead 100644 --- a/src/base/coordinate-sparse.lisp +++ b/src/base/coordinate-sparse.lisp @@ -12,9 +12,9 @@ (deft/method t/sparse-fill (sym sparse-tensor) () `(t/fid+ (t/field-type ,sym))) -(deft/method t/store-allocator (sym coordinate-sparse-tensor) (size &optional initial-element) +(deft/method t/store-allocator (sym coordinate-sparse-tensor) (size &optional nz) (with-gensyms (size-sym) - `(let ((,size-sym (t/compute-store-size ,sym ,size))) + `(let ((,size-sym (or ,nz (min (max sb-impl::+min-hash-table-size+ (ceiling (/ ,size *default-sparsity*))) *max-sparse-size*)))) (make-hash-table :size ,size-sym)))) (deft/method t/store-ref (sym coordinate-sparse-tensor) (store &rest idx) @@ -37,16 +37,8 @@ (deft/method t/store-type (sym coordinate-sparse-tensor) (&optional (size '*)) 'hash-table) -(deft/method t/compute-store-size (sym coordinate-sparse-tensor) (size) - `(max (min sb-impl::+min-hash-table-size+ (ceiling (/ ,size *default-sparsity*))) *max-sparse-size*)) - (defmethod head ((tensor coordinate-sparse-tensor)) 0) -;firefox; -(defleaf real-coordinate-sparse-tensor (coordinate-sparse-tensor) ()) - -(deft/method t/field-type (sym real-coordinate-sparse-tensor) () - 'double-float) ;; (defmethod ref ((tensor coordinate-sparse-tensor) &rest subscripts) (let ((clname (class-name (class-of tensor)))) @@ -69,14 +61,3 @@ (t/store-ref ,clname sto idx)))) (setf (ref tensor (if (numberp (car subscripts)) subscripts (car subscripts))) value))) ;; - -(deft/method t/zeros (class coordinate-sparse-tensor) (dims &optional initial-element) - (with-gensyms (astrs adims sizs) - `(let* ((,adims (make-index-store ,dims))) - (declare (type index-store-vector ,adims)) - (multiple-value-bind (,astrs ,sizs) (make-stride-cmj ,adims) - (declare (type index-store-vector ,astrs)) - (make-instance ',class - :dimensions ,adims - :strides ,astrs - :store (t/store-allocator ,class ,sizs)))))) diff --git a/src/base/sparse-tensor.lisp b/src/base/sparse-tensor.lisp deleted file mode 100644 index e69de29..0000000 diff --git a/src/blas/copy.lisp b/src/blas/copy.lisp index af584dd..146e1b6 100644 --- a/src/blas/copy.lisp +++ b/src/blas/copy.lisp @@ -124,6 +124,9 @@ (assert (very-quickly (lvec-eq (the index-store-vector (dimensions x)) (the index-store-vector (dimensions y)) #'=)) nil 'tensor-dimension-mismatch)) +(defmethod :before copy! ((a sparse-tensor) (b sparse-tensor)) + (assert (< (store-size a) (store-size b)) nil 'tensor-insufficient-store)) + (defmethod copy! ((x standard-tensor) (y standard-tensor)) (let ((clx (class-name (class-of x))) (cly (class-name (class-of y)))) @@ -149,6 +152,41 @@ (error "Don't know how to copy from ~a to ~a" clx cly)))) (copy! x y)) +(defmethod copy! ((x coordinate-sparse-tensor) (y compressed-sparse-matrix)) + (let ((clx (class-name (class-of x))) + (cly (class-name (class-of y)))) + (assert (and (member clx *tensor-type-leaves*) + (member cly *tensor-type-leaves*)) + nil 'tensor-abstract-class :tensor-class (list clx cly)) + (compile-and-eval + `(defmethod copy! ((x ,clx) (y ,cly)) + (let-typed ((stds (strides x) :type index-store-vector)) + (assert (and (tensor-matrixp x) (= (aref stds 0) 1)) nil 'tensor-invalid-stride-value) + (let ((col-stride (aref stds 1)) + (row-data (make-array (ncols x) :initial-element nil))) + (very-quickly + (loop :for key :being :the :hash-keys :of (store x) + :using (hash-value value) + :do (multiple-value-bind (c r) (floor (the index-type key) col-stride) + (push (cons r value) (aref row-data c))))) + (let-typed ((vi (neighbour-start y) :type index-store-vector) + (vr (neighbour-id y) :type index-store-vector) + (vd (store y) :type ,(store-type cly))) + (setf (aref vi 0) 0) + (very-quickly + (loop :for i :from 0 :below (ncols x) + :with col-stop := 0 + :do (let ((rowd (sort (aref row-data i) #'(lambda (x y) (< (the index-type x) (the index-type y))) :key #'car))) + (loop :for (r . v) :in rowd + :do (locally + (declare (type ,(field-type clx) v)) + (setf (aref vr col-stop) r) + (t/store-set real-compressed-sparse-matrix (t/coerce ,(field-type cly) v) vd col-stop) + (incf col-stop))) + (setf (aref vi (1+ i)) col-stop))))) + y)))) + (copy! x y))) + (defmethod copy! ((x t) (y standard-tensor)) (let ((cly (class-name (class-of y)))) (assert (and (member cly *tensor-type-leaves*)) @@ -178,4 +216,10 @@ ((or (not type) (subtypep type 'standard-tensor)) (let ((ret (zeros (dimensions tensor) (or type (class-of tensor))))) (copy! tensor ret))))) - + +(defmethod copy-generic ((tensor sparse-tensor) type) + (cond + ((or (not type) (subtypep type 'sparse-tensor)) + (let ((ret (zeros (dimensions tensor) (or type (class-of tensor)) (store-size tensor)))) + (copy! tensor ret))))) + diff --git a/src/blas/maker.lisp b/src/blas/maker.lisp index cffe047..797b623 100644 --- a/src/blas/maker.lisp +++ b/src/blas/maker.lisp @@ -13,9 +13,32 @@ :strides ,astrs :store (t/store-allocator ,class ,sizs ,@(when initial-element `((t/coerce ,(field-type class) ,initial-element))))))))) +(deft/method t/zeros (class coordinate-sparse-tensor) (dims &optional nz) + (with-gensyms (astrs adims sizs) + `(let* ((,adims (make-index-store ,dims))) + (declare (type index-store-vector ,adims)) + (multiple-value-bind (,astrs ,sizs) (make-stride-cmj ,adims) + (declare (type index-store-vector ,astrs)) + (make-instance ',class + :dimensions ,adims + :strides ,astrs + :store (t/store-allocator ,class ,sizs ,nz)))))) + +(deft/method t/zeros (class compressed-sparse-matrix) (dims &optional nz) + (with-gensyms (dsym) + `(let ((,dsym ,dims)) + (destructuring-bind (vr vd) (t/store-allocator ,class ,dsym ,nz) + (make-instance ',class + :dimensions (make-index-store ,dims) + :neighbour-start (allocate-index-store (1+ (second ,dsym))) + :neighbour-id vr + :store vd))))) + ;; (defgeneric zeros-generic (dims dtype &optional initial-element) - (:documentation "A generic version of @func{zeros}.") + (:documentation " + A generic version of @func{zeros}. +") (:method ((dims cons) (dtype t) &optional initial-element) ;; (assert (member dtype *tensor-type-leaves*) nil 'tensor-abstract-class :tensor-class dtype) (compile-and-eval @@ -26,29 +49,30 @@ (zeros-generic dims dtype initial-element))) (definline zeros (dims &optional (type *default-tensor-type*) initial-element) - " -Create a tensor with dimensions @arg{dims} of class @arg{dtype}. -The optional argument @arg{initial-element} is used in two completely -incompatible ways. - -If @arg{dtype} is a dense tensor, then @arg{initial-element}, is used to -initialize all the elements. If @arg{dtype} is however, a sparse tensor, -it is used for computing the number of nonzeros slots in the store. - -Example: -> (zeros 3) -#<REAL-TENSOR #(3) - 0.0000 0.0000 0.0000 -> - -> (zeros 3 'complex-tensor 2) -#<COMPLEX-TENSOR #(3) - 2.0000 2.0000 2.0000 -> - -> (zeros '(10000 10000) 'real-compressed-sparse-matrix 10000) -#<REAL-COMPRESSED-SPARSE-MATRIX #(10000 10000), store-size: 10000> -" (let ((*check-after-initializing?* nil)) +" + Create a tensor with dimensions @arg{dims} of class @arg{dtype}. + The optional argument @arg{initial-element} is used in two completely + incompatible ways. + + If @arg{dtype} is a dense tensor, then @arg{initial-element}, is used to + initialize all the elements. If @arg{dtype} is however, a sparse tensor, + it is used for computing the number of nonzeros slots in the store. + + Example: + > (zeros 3) + #<REAL-TENSOR #(3) + 0.0000 0.0000 0.0000 + > + + > (zeros 3 'complex-tensor 2) + #<COMPLEX-TENSOR #(3) + 2.0000 2.0000 2.0000 + > + + > (zeros '(10000 10000) 'real-compressed-sparse-matrix 10000) + #<REAL-COMPRESSED-SPARSE-MATRIX #(10000 10000), store-size: 10000> +" + (let ((*check-after-initializing?* nil)) (let ((type (etypecase type (standard-class (class-name type)) (symbol type)))) (etypecase dims (vector @@ -57,4 +81,3 @@ Example: (zeros-generic dims type initial-element)) (fixnum (zeros-generic (list dims) type initial-element)))))) -;; diff --git a/src/special/map.lisp b/src/special/map.lisp index 272aea9..e84beb5 100644 --- a/src/special/map.lisp +++ b/src/special/map.lisp @@ -1,19 +1,29 @@ (in-package #:matlisp) (defgeneric mapsor! (func x y) - (:documentation " - Syntax - ====== - (MAPSOR! func x y) + (:documentation +" + Syntax + ====== + (MAPSOR! func x y) - Purpose - ======= - Applies the function element-wise on x, and sets the corresponding - elements in y to the value returned by the function. + Purpose + ======= + Applies the function element-wise on x, and sets the corresponding + elements in y to the value returned by the function. - Example - ======= - > (mapsor! #'sin (randn '(2 2)) (zeros '(2 2))) + Example + ======= + > (mapsor! #'(lambda (idx x y) + (if (= (car idx) (cadr idx)) + (sin x) + y)) + (randn '(2 2)) (zeros '(2 2))) + #<REAL-TENSOR #(2 2) + -9.78972E-2 0.0000 + 0.0000 -.39243 + > + > ") (:method :before ((func function) (x standard-tensor) (y standard-tensor)) (assert (very-quickly (lvec-eq (dimensions x) (dimensions y))) nil 'tensor-dimension-mismatch))) @@ -27,23 +37,38 @@ nil 'tensor-abstract-class :tensor-class (list clx cly)) (compile-and-eval `(defmethod mapsor! ((func function) (x ,clx) (y ,cly)) - (let ((sto-x (store x)) - (sto-y (store y)) - (idxlst (make-list (order x)))) - (declare (type ,(store-type clx) sto-x) - (type ,(store-type cly) sto-y)) - (very-quickly - (mod-dotimes (idx (dimensions x)) - :with (linear-sums - (of-x (strides x)) - (of-y (strides y))) - :do (t/store-set ,cly (funcall func (lvec->list! idx idxlst) (t/store-ref ,clx sto-x of-x) (t/store-ref ,cly sto-y of-y)) sto-y of-y)))) + (let-typed ((sto-x (store x) :type ,(store-type clx)) + (sto-y (store y) :type ,(store-type cly))) + (mod-dotimes (idx (dimensions x)) + :with (linear-sums + (of-x (strides x) (head x)) + (of-y (strides y) (head y))) + :do (t/store-set ,cly (funcall func (lvec->list idx) (t/store-ref ,clx sto-x of-x) (t/store-ref ,cly sto-y of-y)) sto-y of-y))) y))) (mapsor! func x y)) -(definline mapsor (func x) - (let ((ret (zeros (dimensions x) (class-of x)))) - (mapsor! func x ret))) +(defmethod mapsor! ((func function) (x standard-tensor) (y standard-tensor)) + (let ((clx (class-name (class-of x))) + (cly (class-name (class-of y)))) + (assert (and + (member clx *tensor-type-leaves*) + (member cly *tensor-type-leaves*)) + nil 'tensor-abstract-class :tensor-class (list clx cly)) + (compile-and-eval + `(defmethod mapsor! ((func function) (x ,clx) (y ,cly)) + (let-typed ((sto-x (store x) :type ,(store-type clx)) + (sto-y (store y) :type ,(store-type cly))) + (mod-dotimes (idx (dimensions x)) + :with (linear-sums + (of-x (strides x) (head x)) + (of-y (strides y) (head y))) + :do (t/store-set ,cly (funcall func (lvec->list idx) (t/store-ref ,clx sto-x of-x) (t/store-ref ,cly sto-y of-y)) sto-y of-y))) + y))) + (mapsor! func x y)) + +(definline mapsor (func x &optional output-type) + (let ((ret (zeros (dimensions x) (or output-type (class-of x))))) + (mapsor! #'(lambda (idx x y) (declare (ignore y)) (funcall func idx x)) x ret))) ;; (defun mapslice (func x &optional (axis 0)) commit 6b070ed0049cd5271379c18e7a08e6f222d3b015 Author: Akshay Srinivasan <aks...@gm...> Date: Sat Mar 1 14:20:34 2014 -0800 Added a proper shuffler. diff --git a/src/base/permutation.lisp b/src/base/permutation.lisp index 189024d..1063ed1 100644 --- a/src/base/permutation.lisp +++ b/src/base/permutation.lisp @@ -31,11 +31,23 @@ (definline pidxv (&rest contents) (make-array (length contents) :element-type 'pindex-type :initial-contents contents)) -;;Write a uniform randomiser -(defun seqrnd (seq) +(defun pick-random (k n) + (let ((ret nil) + (perm (allocate-pindex-store k))) + (loop :for i :from 0 :below k + :do (let ((sd (random (- n i)))) + (loop :for ele :in ret + :do (if (> ele sd) (return) (incf sd))) + (setf (aref perm i) sd) + (setf ret (merge 'list (list sd) ret #'<)))) + (values ret perm))) + +(defun shuffle (seq) "Randomize the elements of a sequence. Destructive on SEQ." - (sort seq #'> :key #'(lambda (x) (declare (ignore x)) - (random 1.0)))) + (let* ((len (length seq)) + (perm (nth-value 1 (pick-random len len)))) + (apply-action! seq perm))) +#+nil(sort seq #'> :key #'(lambda (x) (declare (ignore x)) (random 1.0))) ;;Class definitions----------------------------------------------;; (defclass permutation () commit 749437c8bb376d094b604c6977a7e7c037a522a0 Author: Akshay Srinivasan <aks...@gm...> Date: Sat Mar 1 13:01:36 2014 -0800 Saving state on Sparse tensors. diff --git a/src/base/compressed-sparse.lisp b/src/base/compressed-sparse.lisp new file mode 100644 index 0000000..85b65d3 --- /dev/null +++ b/src/base/compressed-sparse.lisp @@ -0,0 +1,187 @@ +(in-package #:matlisp) + +;; +(defclass compressed-sparse-matrix (sparse-tensor) + ((transpose? :initform nil :initarg :transpose? :reader transpose? :type boolean + :documentation "If NIL the matrix is in CSC, else if T, then matrix is CSR.") + (neighbour-start :initarg :neighbour-start :reader neighbour-start :type index-store-vector + :documentation "Start index for ids and store.") + (neighbour-id :initarg :neighbour-id :reader neighbour-id :type index-store-vector + :documentation "Row id."))) + +(defun compressed-sparse-indexing (subs tensor) + (declare (type compressed-sparse-matrix tensor) + (type (or index-store-vector cons) subs)) + (let-typed ((row 0 :type index-type) + (col 0 :type index-type)) + (etypecase subs + (cons + (assert (null (cddr subs)) nil 'tensor-index-rank-mismatch) + (setf row (the index-type (car subs)) + col (the index-type (cadr subs)))) + (index-store-vector + (assert (= (length subs) 2) nil 'tensor-index-rank-mismatch) + (setf row (the index-type (aref subs 0)) + col (the index-type (aref subs 1))))) + (when (transpose? tensor) + (rotatef row col)) + (let*-typed ((nst (neighbour-start tensor) :type index-store-vector) + (nid (neighbour-id tensor) :type index-store-vector) + (lb (aref nst col) :type index-type) + (ub (aref nst (1+ col)) :type index-type)) + (declare (type index-type row col)) + (if (or (= lb ub) (< row (aref nid lb)) (> row (aref nid (1- ub)))) -1 + (very-quickly + (loop :with j := (ash (+ lb ub) -1) + :repeat 64 + :do (progn + #+nil(format t "~a, ~a, ~a~%" lb j ub) + (cond + ((= (aref nid j) row) (return j)) + ((>= lb (1- ub)) (return -1)) + (t + (if (< row (aref nid j)) + (setf ub j) + (setf lb (1+ j))) + (setf j (ash (+ lb ub) -1))))))))))) + +(deft/method t/store-allocator (sym compressed-sparse-matrix) (size &optional initial-element) + (let ((sto-type (store-element-type sym))) + (using-gensyms (decl (size)) + `(let (,@decl) + (destructuring-bind (ni nz) (t/compute-store-size ,sym ,size) + (list + (allocate-index-store (1+ ni)) + (allocate-index-store nz) + (make-array nz :element-type ',sto-type :initial-element ,(if (subtypep sto-type 'number) `(t/fid+ ,sto-type) nil)))))))) + +(deft/method t/compute-store-size (sym compressed-sparse-matrix) (size) + `(destructuring-bind (nr nc &optional nz) ,size + (list nc (or nz (min (ceiling (* nr nc *default-sparsity*)) *max-sparse-size*))))) + +(deft/method t/store-type (sym compressed-sparse-matrix) (&optional (size '*)) + `(simple-array ,(store-element-type sym) (,size))) + +(deft/method t/store-ref (sym compressed-sparse-matrix) (store &rest idx) + (assert (null (cdr idx)) nil "given more than one index for compressed-store") + `(aref (the ,(store-type sym) ,store) (the index-type ,(car idx)))) + +(deft/method t/store-size (sym compressed-sparse-matrix) (ele) + `(length ,ele)) + +(deft/method t/store-element-type (sym compressed-sparse-matrix) () + (macroexpand `(t/field-type ,sym))) + +;; +(deft/method t/store-set (sym compressed-sparse-matrix) (value store &rest idx) + (assert (null (cdr idx)) nil "given more than one index for compressed store") + `(setf (aref (the ,(store-type sym) ,store) (the index-type ,(car idx))) (the ,(field-type sym) ,value))) +;; (deft/method t/store-set (sym coordinate-sparse-tensor) (value store &rest idx) +;; (assert (null (cdr idx)) nil "given more than one index for hashtable.") +;; (with-gensyms (val) +;; `(let-typed ((,val ,value :type ,(field-type sym))) +;; (unless (t/f= ,(field-type sym) ,val (t/fid+ ,(field-type sym))) +;; (setf (gethash ,(car idx) ,store) (the ,(field-type sym) ,value)))))) + + +;; +(defmethod ref ((tensor compressed-sparse-matrix) &rest subscripts) + (let ((clname (class-name (class-of tensor)))) + (assert (member clname *tensor-type-leaves*) nil 'tensor-abstract-class :tensor-class clname) + (compile-and-eval + `(defmethod ref ((tensor ,clname) &rest subscripts) + (let ((idx (compressed-sparse-indexing (if (numberp (car subscripts)) subscripts (car subscripts)) tensor))) + (if (< idx 0) + (t/sparse-fill ,clname) + (t/store-ref ,clname (store tensor) idx))))) + (apply #'ref (cons tensor subscripts)))) + +#+nil +(defmethod (setf ref) (value (tensor compressed-sparse-matrix) &rest subscripts) + (let ((clname (class-name (class-of tensor)))) + (assert (member clname *tensor-type-leaves*) nil 'tensor-abstract-class :tensor-class clname) + (compile-and-eval + `(defmethod (setf ref) (value (tensor ,clname) &rest subscripts) + (let* ((subs (if (numberp (car subscripts)) subscripts (car subscripts))) + (idx (store-indexing subs tensor)) + (sto (store tensor))) + (t/store-set ,clname (t/coerce ,(field-type clname) value) sto idx) + (t/store-ref ,clname sto idx)))) + (setf (ref tensor (if (numberp (car subscripts)) subscripts (car subscripts))) value))) +;; +(defleaf real-compressed-sparse-matrix (compressed-sparse-matrix) ()) +(deft/method t/field-type (sym real-compressed-sparse-matrix) () + 'double-float) + +;; +(defmethod :before copy! ((a sparse-tensor) (b sparse-tensor)) + (assert (< (store-size a) (store-size b)) nil 'tensor-insufficient-store)) + +(deft/method t/zeros (class compressed-sparse-matrix) (dims &optional nz) + `(destructuring-bind (vi vr vd) (t/store-allocator ,class (append ,dims ,@(when nz `((list ,nz))))) + (make-instance ',class + :dimensions (make-index-store ,dims) + :neighbour-start vi + :neighbour-id vr + :store vd))) + +(defmethod copy! ((x coordinate-sparse-tensor) (y compressed-sparse-matrix)) + (let ((clx (class-name (class-of x))) + (cly (class-name (class-of y)))) + (assert (and (member clx *tensor-type-leaves*) + (member cly *tensor-type-leaves*)) + nil 'tensor-abstract-class :tensor-class (list clx cly)) + (compile-and-eval + `(defmethod copy! ((x ,clx) (y ,cly)) + (let-typed ((stds (strides x) :type index-store-vector)) + (assert (and (tensor-matrixp x) (= (aref stds 0) 1)) nil 'tensor-invalid-stride-value) + (let ((col-stride (aref stds 1)) + (row-data (make-array (ncols x) :initial-element nil))) + (very-quickly + (loop :for key :being :the :hash-keys :of (store x) + :using (hash-value value) + :do (multiple-value-bind (c r) (floor (the index-type key) col-stride) + (push (cons r value) (aref row-data c))))) + (let-typed ((vi (neighbour-start y) :type index-store-vector) + (vr (neighbour-id y) :type index-store-vector) + (vd (store y) :type ,(store-type cly))) + (setf (aref vi 0) 0) + (very-quickly + (loop :for i :from 0 :below (ncols x) + :with col-stop := 0 + :do (let ((rowd (sort (aref row-data i) #'(lambda (x y) (< (the index-type x) (the index-type y))) :key #'car))) + (loop :for (r . v) :in rowd + :do (locally + (declare (type ,(field-type clx) v)) + (setf (aref vr col-stop) r) + (t/store-set real-compressed-sparse-matrix (t/coerce ,(field-type cly) v) vd col-stop) + (incf col-stop))) + (setf (aref vi (1+ i)) col-stop))))) + y)))) + (copy! x y))) + +(defmethod copy-generic ((a sparse-tensor) (type (eql 'real-compressed-sparse-matrix))) + (let-typed ((stds (strides a) :type index-store-vector)) + (assert (and (tensor-matrixp a) (= (aref stds 0) 1)) nil 'tensor-not-matrix) + (let ((col-stride (aref stds 1)) + (row-data (make-array (ncols a) :initial-element nil))) + (loop :for key :being :the :hash-keys :of (store a) + :using (hash-value value) + :do (multiple-value-bind (c r) (floor key col-stride) + (push (cons r value) (aref row-data c)))) + (destructuring-bind (vi vr vd) (t/store-allocator real-compressed-sparse-matrix (append (dims a) (list (store-size a)))) + (setf (aref vi 0) 0) + (loop :for i :from 0 :below (ncols a) + :with col-stop := 0 + :do (let ((rowd (sort (aref row-data i) #'< :key #'car))) + (loop :for (r . v) :in rowd + :do (progn + (setf (aref vr col-stop) r + (aref vd col-stop) v) + (incf col-stop))) + (setf (aref vi (1+ i)) col-stop))) + (make-instance 'real-compressed-sparse-matrix + :dimensions (copy-seq (dimensions a)) + :neighbour-start vi + :neighbour-id vr + :store vd))))) diff --git a/src/base/coordinate-sparse.lisp b/src/base/coordinate-sparse.lisp new file mode 100644 index 0000000..2365eb0 --- /dev/null +++ b/src/base/coordinate-sparse.lisp @@ -0,0 +1,82 @@ +(in-package :matlisp) + +;;One may to do better than a Hash-table for this. +(defparameter *default-sparsity* 1/1000) +(defparameter *max-sparse-size* 10000) + +(defclass coordinate-sparse-tensor (sparse-tensor) + ((strides :initarg :strides :reader strides :type index-store-vector + :documentation "Strides for accesing elements of the tensor."))) + +(deft/generic (t/sparse-fill #'subtypep) sym ()) +(deft/method t/sparse-fill (sym sparse-tensor) () + `(t/fid+ (t/field-type ,sym))) + +(deft/method t/store-allocator (sym coordinate-sparse-tensor) (size &optional initial-element) + (with-gensyms (size-sym) + `(let ((,size-sym (t/compute-store-size ,sym ,size))) + (make-hash-table :size ,size-sym)))) + +(deft/method t/store-ref (sym coordinate-sparse-tensor) (store &rest idx) + (assert (null (cdr idx)) nil "given more than one index for hashtable.") + `(the ,(field-type sym) (gethash ,(car idx) ,store (t/sparse-fill ,sym)))) + +(deft/method t/store-set (sym coordinate-sparse-tensor) (value store &rest idx) + (assert (null (cdr idx)) nil "given more than one index for hashtable.") + (with-gensyms (val) + `(let-typed ((,val ,value :type ,(field-type sym))) + (unless (t/f= ,(field-type sym) ,val (t/fid+ ,(field-type sym))) + (setf (gethash ,(car idx) ,store) (the ,(field-type sym) ,value)))))) + +(deft/method t/store-type (sym coordinate-sparse-tensor) (&optional (size '*)) + 'hash-table) + +(deft/method t/store-size (sym coordinate-sparse-tensor) (ele) + `(hash-table-count ,ele)) + +(deft/method t/store-type (sym coordinate-sparse-tensor) (&optional (size '*)) + 'hash-table) + +(deft/method t/compute-store-size (sym coordinate-sparse-tensor) (size) + `(max (min sb-impl::+min-hash-table-size+ (ceiling (/ ,size *default-sparsity*))) *max-sparse-size*)) + +(defmethod head ((tensor coordinate-sparse-tensor)) + 0) +;firefox; +(defleaf real-coordinate-sparse-tensor (coordinate-sparse-tensor) ()) + +(deft/method t/field-type (sym real-coordinate-sparse-tensor) () + 'double-float) +;; +(defmethod ref ((tensor coordinate-sparse-tensor) &rest subscripts) + (let ((clname (class-name (class-of tensor)))) + (assert (member clname *tensor-type-leaves*) nil 'tensor-abstract-class :tensor-class clname) + (compile-and-eval + `(defmethod ref ((tensor ,clname) &rest subscripts) + (let ((subs (if (numberp (car subscripts)) subscripts (car subscripts)))) + (t/store-ref ,clname (store tensor) (store-indexing subs tensor))))) + (apply #'ref (cons tensor subscripts)))) + +(defmethod (setf ref) (value (tensor coordinate-sparse-tensor) &rest subscripts) + (let ((clname (class-name (class-of tensor)))) + (assert (member clname *tensor-type-leaves*) nil 'tensor-abstract-class :tensor-class clname) + (compile-and-eval + `(defmethod (setf ref) (value (tensor ,clname) &rest subscripts) + (let* ((subs (if (numberp (car subscripts)) subscripts (car subscripts))) + (idx (store-indexing subs tensor)) + (sto (store tensor))) + (t/store-set ,clname (t/coerce ,(field-type clname) value) sto idx) + (t/store-ref ,clname sto idx)))) + (setf (ref tensor (if (numberp (car subscripts)) subscripts (car subscripts))) value))) +;; + +(deft/method t/zeros (class coordinate-sparse-tensor) (dims &optional initial-element) + (with-gensyms (astrs adims sizs) + `(let* ((,adims (make-index-store ,dims))) + (declare (type index-store-vector ,adims)) + (multiple-value-bind (,astrs ,sizs) (make-stride-cmj ,adims) + (declare (type index-store-vector ,astrs)) + (make-instance ',class + :dimensions ,adims + :strides ,astrs + :store (t/store-allocator ,class ,sizs)))))) diff --git a/src/base/loopopt.lisp b/src/base/loopopt.lisp index 20c33b2..7c2257a 100644 --- a/src/base/loopopt.lisp +++ b/src/base/loopopt.lisp @@ -2,6 +2,10 @@ ;;diagonal-copy ;; i, j; must be indices in some tensor. +;; (with-tensors ((a .. :type real-tensor) +;; (b .. :type real-tensor)) +;; :do (forall (i j) :st (= i j) :do (setf (ref a i j) (ref b i j)))) + (defparameter *code* `((forall (i j) :st (= i j) :do (setf (ref a i j) (ref b i j))) (forall (i j) :st (= i j) :do (setf (ref a i j) (ref b i j))) @@ -13,6 +17,12 @@ ;;mod-loop (forall (&rest idx) :order :col-major :st (< idx (dimensions a)) :do (setf (ref a idx) (ref b idx))))) +;; `(let (,@stores +;; ,@dimensions +;; ,@strides +;; ,@heads) + + (defparameter *expr* (mapcar #'(lambda (x) (find-tag x :do)) *code*)) diff --git a/src/base/print.lisp b/src/base/print.lisp index 48b0042..f2441c3 100644 --- a/src/base/print.lisp +++ b/src/base/print.lisp @@ -112,7 +112,7 @@ of a matrix (default 0) (defmethod print-object ((tensor sparse-tensor) stream) (print-unreadable-object (tensor stream :type t) - (format stream (if (slot-value tensor 'parent-tensor) - "~A~,4T:DISPLACED" - "~A") - (dimensions tensor)))) + (format stream + (string+ "~A, store-size: ~A" + (if (slot-value tensor 'parent-tensor) ",4T:DISPLACED" "")) + (dimensions tensor) (store-size tensor)))) diff --git a/src/base/sparse-tensor.lisp b/src/base/sparse-tensor.lisp index 4119a3f..e69de29 100644 --- a/src/base/sparse-tensor.lisp +++ b/src/base/sparse-tensor.lisp @@ -1,134 +0,0 @@ -(in-package :matlisp) - -;;One may to do better than a Hash-table for this. -(defparameter *default-sparsity* 1/1000) -(defparameter *max-size* 10000) - -(defclass coordinate-sparse-tensor (sparse-tensor) - ((strides :initarg :strides :reader strides :type index-store-vector - :documentation "Strides for accesing elements of the tensor."))) - -(deft/generic (t/sparse-fill #'subtypep) sym ()) -(deft/method t/sparse-fill (sym sparse-tensor) () - `(t/fid+ (t/field-type ,sym))) - -(deft/method t/store-allocator (sym coordinate-sparse-tensor) (size &optional initial-element) - (with-gensyms (size-sym) - `(let ((,size-sym (t/compute-store-size ,sym ,size))) - (make-hash-table :size ,size-sym)))) - -(deft/method t/store-ref (sym coordinate-sparse-tensor) (store &rest idx) - (assert (null (cdr idx)) nil "given more than one index for hashtable.") - `(the ,(field-type sym) (gethash ,(car idx) ,store (t/sparse-fill ,sym)))) - -(deft/method t/store-set (sym coordinate-sparse-tensor) (value store &rest idx) - (assert (null (cdr idx)) nil "given more than one index for hashtable.") - (with-gensyms (val) - `(let-typed ((,val ,value :type ,(field-type sym))) - (unless (t/f= ,(field-type sym) ,val (t/fid+ ,(field-type sym))) - (setf (gethash ,(car idx) ,store) (the ,(field-type sym) ,value)))))) - -(deft/method t/store-type (sym coordinate-sparse-tensor) (&optional (size '*)) - 'hash-table) - -(deft/method t/store-size (sym coordinate-sparse-tensor) (ele) - `(hash-table-count ,ele)) - -(deft/method t/store-type (sym coordinate-sparse-tensor) (&optional (size '*)) - 'hash-table) - -(deft/method t/compute-store-size (sym coordinate-sparse-tensor) (size) - `(max (min sb-impl::+min-hash-table-size+ (ceiling (/ ,size *default-sparsity*))) *max-sparse-size*)) - -(defmethod head ((tensor coordinate-sparse-tensor)) - 0) -;; -(defleaf real-sparse-tensor (coordinate-sparse-tensor) ()) - -(deft/method t/field-type (sym real-sparse-tensor) () - 'double-float) -;; -(defmethod ref ((tensor coordinate-sparse-tensor) &rest subscripts) - (let ((clname (class-name (class-of tensor)))) - (assert (member clname *tensor-type-leaves*) nil 'tensor-abstract-class :tensor-class clname) - (compile-and-eval - `(defmethod ref ((tensor ,clname) &rest subscripts) - (let ((subs (if (numberp (car subscripts)) subscripts (car subscripts)))) - (t/store-ref ,clname (store tensor) (store-indexing subs tensor))))) - (apply #'ref (cons tensor subscripts)))) - -(defmethod (setf ref) (value (tensor coordinate-sparse-tensor) &rest subscripts) - (let ((clname (class-name (class-of tensor)))) - (assert (member clname *tensor-type-leaves*) nil 'tensor-abstract-class :tensor-class clname) - (compile-and-eval - `(defmethod (setf ref) (value (tensor ,clname) &rest subscripts) - (let* ((subs (if (numberp (car subscripts)) subscripts (car subscripts))) - (idx (store-indexing subs tensor)) - (sto (store tensor))) - (t/store-set ,clname (t/coerce ,(field-type clname) value) sto idx) - (t/store-ref ,clname sto idx)))) - (setf (ref tensor (if (numberp (car subscripts)) subscripts (car subscripts))) value))) - -;; -(defclass compressed-sparse-matrix (sparse-tensor) - ((index-position :initarg :strides :reader index-position :type index-store-vector - :documentation "Strides for accesing elements of the tensor.") - (indices :initarg :strides :reader indices :type index-store-vector - :documentation "Strides for accesing elements of the tensor."))) - -(defclass ccs-matrix (compressed-sparse-matrix) ()) -(defclass crs-matrix (compressed-sparse-matrix) ()) - - -(deft/method t/store-allocator (sym compressed-sparse-matrix) (size &optional initial-element) - (using-gensyms (decl (size)) - `(let (,@decl) - (destructuring-bind (ni nz) (t/compute-store-size ,sym ,size) - (list - (allocate-index-store ni) - (allocate-index-store nz) - (make-array nz :element-type ,(store-element-type sym) :initial-element ,(if (subtypep type 'number) `(t/fid+ ,type) nil))))))) - -(deft/method t/compute-store-size (sym ccs-matrix) (size) - `(destructuring-bind (nr nc &optional nz) size - (unless nz (setq nz (min (ceiling (* nr nc *default-sparsity*)) *max-sparse-size*))) - (list nr nz nil))) - -(deft/method t/compute-store-size (sym ccs-matrix) (size) - (using-gensyms (decl (size)) - `(let (,@decl) - (destructuring-bind (nr nc &optional nz) size - (unless nz (setq nz (min (ceiling (* nr nc *default-sparsity*)) *max-sparse-size*))) - (list nc nz nil))))) - -(t/compute-store-size ccs-matrix '(10 10)) -(deft/method t/compute-store-size (sym ccr-matrix) (size) - `(append ,size t)) - - -(deft/method t/compute-store-size (sym ccs-matrix) (size) - `(max (min sb-impl::+min-hash-table-size+ (ceiling (/ ,size *default-sparsity*))) *max-size*)) - - - -(defun coordinate->ccs (tensor) - (assert (eql (nth-value 2 (blas-matrix-compatiblep tensor #\n)) :col-major) nil "nooo!") - (labels ((rref (idx) - (multiple-value-list (floor idx (col-stride tensor)))) - (convert-sto () - (let ((sto (store tensor)) - (nsto (make-hash-table))) - (maphash #'(lambda (k v) - (destructuring-bind (r c) (rref k) - (unless (nth-value 1 (gethash c nsto)) - (setf (gethash c nsto) (cons nil nil))) - (push r (car (gethash c nsto))) - (push v (cdr (gethash c nsto))))) - sto) - (maphash #'(lambda (k v) - (setf (car v) (make-index-store (car v)) - (cdr v) (make-array (length (cdr v)) :initial-contents (cdr v)))) nsto) - nsto))) - (convert-sto))) - -(defclass ccs-sparse-matrix (sparse-tensor) ()) diff --git a/src/blas/axpy.lisp b/src/blas/axpy.lisp index 2e28522..48e2d7d 100644 --- a/src/blas/axpy.lisp +++ b/src/blas/axpy.lisp @@ -100,7 +100,7 @@ Same as AXPY except that the result is stored in Y and Y is returned. ") - (:method :before ((alpha number) (x standard-tensor) (y standard-tensor)) + (:method :before ((alpha number) (x base-tensor) (y base-tensor)) (assert (lvec-eq (dimensions x) (dimensions y) #'=) nil 'tensor-dimension-mismatch))) diff --git a/src/blas/copy.lisp b/src/blas/copy.lisp index 12c6b41..af584dd 100644 --- a/src/blas/copy.lisp +++ b/src/blas/copy.lisp @@ -120,7 +120,7 @@ ,y)))) ;; -(defmethod copy! :before ((x standard-tensor) (y standard-tensor)) +(defmethod copy! :before ((x base-tensor) (y base-tensor)) (assert (very-quickly (lvec-eq (the index-store-vector (dimensions x)) (the index-store-vector (dimensions y)) #'=)) nil 'tensor-dimension-mismatch)) @@ -178,3 +178,4 @@ ((or (not type) (subtypep type 'standard-tensor)) (let ((ret (zeros (dimensions tensor) (or type (class-of tensor))))) (copy! tensor ret))))) + diff --git a/src/blas/maker.lisp b/src/blas/maker.lisp index 0a86d0b..cffe047 100644 --- a/src/blas/maker.lisp +++ b/src/blas/maker.lisp @@ -11,51 +11,50 @@ :dimensions ,adims :head 0 :strides ,astrs - :store (t/store-allocator ,class ,sizs ,@(when initial-element `(,initial-element)))))))) - -;; (deft/method t/zeros (class coordinate-sparse-tensor) (dims &optional initial-element) -;; (with-gensyms (astrs adims sizs) -;; `(let* ((,adims (make-index-store ,dims))) -;; (declare (type index-store-vector ,adims)) -;; (multiple-value-bind (,astrs ,sizs) (make-stride ,adims) -;; (declare (type index-store-vector ,astrs)) -;; (make-instance ',class -;; :dimensions ,adims -;; :strides ,astrs -;; :store (t/store-allocator ,class ,sizs)))))) - -;; (deft/method t/zeros (class compressed-sparse-matrix) (dims &optional initial-element) -;; (assert (= (length dims) 2) nil 'tensor-not-matrix) -;; (with-gensyms (adims az ar ac) -;; `(let* ((,adims (make-index-store ,dims)) -;; (,ar ,(first dims)) -;; (,ac ,(second dims)) -;; (,az (min (ceiling (* ,ar ,ac *default-sparsity*)) *max-sparse-size*))) -;; (declare (type index-store-vector ,adims)) -;; (destructuring-bind (idxp idxi dat) (t/store-allocator ,class (t/compute-store-size ,class (list ,ar ,ac ,az))) -;; (make-instance ',class -;; :dimensions ,adims -;; :index-position idxp -;; :indices idxi -;; :store dat))))) + :store (t/store-allocator ,class ,sizs ,@(when initial-element `((t/coerce ,(field-type class) ,initial-element))))))))) ;; -(defgeneric zeros-generic (dims dtype) - (:documentation "Create a tensor with dimensions @arg{dims} of class @arg{dtype}.") - (:method ((dims cons) (dtype t)) +(defgeneric zeros-generic (dims dtype &optional initial-element) + (:documentation "A generic version of @func{zeros}.") + (:method ((dims cons) (dtype t) &optional initial-element) ;; (assert (member dtype *tensor-type-leaves*) nil 'tensor-abstract-class :tensor-class dtype) (compile-and-eval - `(defmethod zeros-generic ((dims cons) (dtype (eql ',dtype))) - (t/zeros ,dtype dims))) - (zeros-generic dims dtype))) + `(defmethod zeros-generic ((dims cons) (dtype (eql ',dtype)) &optional initial-element) + (if initial-element + (t/zeros ,dtype dims initial-element) + (t/zeros ,dtype dims)))) ... [truncated message content] |
From: Akshay S. <ak...@us...> - 2014-02-19 05:11:46
|
This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "matlisp". The branch, tensor has been updated via f38e6dde50fbe1552793f8146fa42734d522e9c9 (commit) via 4ae0303bba3df2d7d9b3470181947a0056d72e1b (commit) via 2222db6683c9dbf031cd4db8db5214efe60b6d66 (commit) via 6c30013f4baa53a1b9fba64854c5c1e5cae44809 (commit) via c248fe3323b34374070cb9df9a6d765a85e73b01 (commit) via 17a8a5233aa62740a17e8049835976f7a18e3d26 (commit) via 2e87492c26e3e9f0705efda698f6183d9c1425ea (commit) via 4d63cc7ebed68cf20b1b4e83cbfb6b8815706a4e (commit) via b6f729d172193ff03cf1ba88d1deb1c7634ee11f (commit) via 1c59134bdfcda89a91ce78f8d69836fd3a2628ec (commit) via 7cd35fab7aa468327b733ab1d5037a5e98c55e08 (commit) via e51ecd915cbd2a9222b653d70bda556411616999 (commit) via 983fa49410b5ff5805ef9f63776884fc72015f49 (commit) via 673b1af27a8d2ef318dc02b9b73aa9ce2f758fcc (commit) via ad1dd99286b8c8f0ec1323aaca6911f7f3fd4c99 (commit) via 8a5ade0a47e01bd93e19f72fcfe9691ed00f71cf (commit) via 57618ec426afa04b6553dec19c4c96971c98f5ad (commit) from 7ddfe787e54e485108ff96839495e7a6f0d490c2 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit f38e6dde50fbe1552793f8146fa42734d522e9c9 Author: Akshay Srinivasan <aks...@gm...> Date: Tue Feb 18 21:12:52 2014 -0800 Moved all the BLAS things into one folder. Moved gemv, gemm to use define-tensor-method. diff --git a/matlisp.asd b/matlisp.asd index 71c0a25..719f4f8 100644 --- a/matlisp.asd +++ b/matlisp.asd @@ -136,8 +136,8 @@ (:file "symbolic-tensor") (:file "matrix" :depends-on ("numeric")))) - (:module "matlisp-level-1" - :pathname "level-1" + (:module "matlisp-blas" + :pathname "blas" :depends-on ("matlisp-base" "matlisp-classes" "foreign-core") :components ((:file "maker") (:file "copy" @@ -154,31 +154,27 @@ (:file "trans" :depends-on ("scal" "copy")) (:file "sum" - :depends-on ("dot" "copy")))) - (:module "matlisp-level-2" - :pathname "level-2" - :depends-on ("matlisp-base" "matlisp-classes" "foreign-core" "matlisp-level-1") - :components ((:file "gemv"))) - (:module "matlisp-level-3" - :pathname "level-3" - :depends-on ("matlisp-base" "matlisp-classes" "foreign-core" "matlisp-level-1" "matlisp-level-2") - :components ((:file "gemm"))) + :depends-on ("dot" "copy")) + (:file "gemv" + :depends-on ("copy")) + (:file "gemm" + :depends-on ("copy")))) (:module "matlisp-lapack" :pathname "lapack" - :depends-on ("matlisp-base" "matlisp-classes" "matlisp-level-1" "matlisp-level-2" "matlisp-level-3") + :depends-on ("matlisp-base" "matlisp-classes" "matlisp-blas") :components ((:file "lu") (:file "chol") (:file "eig") (:file "least-squares"))) (:module "matlisp-special" :pathname "special" - :depends-on ("matlisp-base" "matlisp-classes" "matlisp-level-1" "matlisp-level-2" "matlisp-level-3") + :depends-on ("matlisp-base" "matlisp-classes" "matlisp-blas") :components ((:file "random") (:file "map") (:file "seq"))) (:module "matlisp-sugar" :pathname "sugar" - :depends-on ("matlisp-base" "matlisp-classes" "matlisp-level-1" "matlisp-level-2" "matlisp-level-3") + :depends-on ("matlisp-base" "matlisp-classes" "matlisp-blas") :components (#+nil (:file "mplusminus") #+nil diff --git a/src/level-1/axpy.lisp b/src/blas/axpy.lisp similarity index 100% rename from src/level-1/axpy.lisp rename to src/blas/axpy.lisp diff --git a/src/level-1/copy.lisp b/src/blas/copy.lisp similarity index 100% rename from src/level-1/copy.lisp rename to src/blas/copy.lisp diff --git a/src/level-1/dot.lisp b/src/blas/dot.lisp similarity index 100% rename from src/level-1/dot.lisp rename to src/blas/dot.lisp diff --git a/src/level-3/gemm.lisp b/src/blas/gemm.lisp similarity index 80% rename from src/level-3/gemm.lisp rename to src/blas/gemm.lisp index aadb836..960b03a 100644 --- a/src/level-3/gemm.lisp +++ b/src/blas/gemm.lisp @@ -117,35 +117,21 @@ (= nc-a nr-b) (= nc-b nc-c)) nil 'tensor-dimension-mismatch)))) -(defmethod gemm! (alpha (A standard-tensor) (B standard-tensor) beta (C standard-tensor) &optional (job :nn)) - (let ((cla (class-name (class-of A))) - (clb (class-name (class-of B))) - (clc (class-name (class-of C)))) - (assert (and (member cla *tensor-type-leaves*) - (member clb *tensor-type-leaves*) - (member clc *tensor-type-leaves*)) - nil 'tensor-abstract-class :tensor-class (list cla clb clc)) - (cond - ((ieql cla clb clc) - (compile-and-eval - `(defmethod gemm! (alpha (A ,cla) (B ,clb) beta (C ,clc) &optional (job :nn)) - (let ((alpha (t/coerce ,(field-type cla) alpha)) - (beta (t/coerce ,(field-type cla) beta))) - (declare (type ,(field-type cla) alpha beta)) - (destructuring-bind (joba jobb) (split-job job) - (declare (type character joba jobb)) - ,(recursive-append - (when (subtypep clc 'blas-numeric-tensor) - `(if (call-fortran? C (t/l3-lb ,clc)) - (with-columnification (,cla ((a joba) (b jobb)) (c)) - (multiple-value-bind (lda opa) (blas-matrix-compatiblep a joba) - (multiple-value-bind (ldb opb) (blas-matrix-compatiblep b jobb) - (t/blas-gemm! ,cla alpha A lda B ldb beta C (or (blas-matrix-compatiblep c #\N) 0) opa opb)))))) - `(t/gemm! ,cla alpha A B beta C joba jobb)))) - C)) - (gemm! alpha A B beta C job)) - (t - (error "Don't know how to apply gemm! to classes ~a." (list cla clb clc)))))) +(define-tensor-method gemm! (alpha (A standard-tensor :input) (B standard-tensor :input) beta (C standard-tensor :output) &optional (job :nn)) + `(let ((alpha (t/coerce ,(field-type (cl a)) alpha)) + (beta (t/coerce ,(field-type (cl a)) beta))) + (declare (type ,(field-type (cl a)) alpha beta)) + (destructuring-bind (joba jobb) (split-job job) + (declare (type character joba jobb)) + ,(recursive-append + (when (subtypep (cl c) 'blas-numeric-tensor) + `(if (call-fortran? C (t/l3-lb ,(cl c))) + (with-columnification (,(cl a) ((a joba) (b jobb)) (c)) + (multiple-value-bind (lda opa) (blas-matrix-compatiblep a joba) + (multiple-value-bind (ldb opb) (blas-matrix-compatiblep b jobb) + (t/blas-gemm! ,(cl a) alpha A lda B ldb beta C (or (blas-matrix-compatiblep c #\N) 0) opa opb)))))) + `(t/gemm! ,(cl a) alpha A B beta C joba jobb)))) + 'C) ;;---------------------------------------------------------------;; (defgeneric gemm (alpha a b beta c &optional job) (:documentation diff --git a/src/level-2/gemv.lisp b/src/blas/gemv.lisp similarity index 75% rename from src/level-2/gemv.lisp rename to src/blas/gemv.lisp index c305481..e468a76 100644 --- a/src/level-2/gemv.lisp +++ b/src/blas/gemv.lisp @@ -93,41 +93,27 @@ (aref (the index-store-vector (dimensions A)) (if (member job '(:t :c)) 1 0)))) nil 'tensor-dimension-mismatch))) -(defmethod gemv! (alpha (A standard-tensor) (x standard-tensor) beta (y standard-tensor) &optional (job :n)) - (let ((clx (class-name (class-of x))) - (cly (class-name (class-of y))) - (cla (class-name (class-of A)))) - (assert (and (member cla *tensor-type-leaves*) - (member clx *tensor-type-leaves*) - (member cly *tensor-type-leaves*)) - nil 'tensor-abstract-class :tensor-class (list cla clx cly)) - (cond - ((ieql clx cly cla) - (compile-and-eval - `(defmethod gemv! (alpha (A ,cla) (x ,clx) beta (y ,cly) &optional (job :n)) - (let ((alpha (t/coerce ,(field-type clx) alpha)) - (beta (t/coerce ,(field-type clx) beta)) - (cjob (aref (symbol-name job) 0))) - (declare (type ,(field-type clx) alpha beta) - (type character cjob)) - ,(recursive-append - (when (subtypep clx 'blas-numeric-tensor) - `(if (call-fortran? A (t/l2-lb ,cla)) - (let ((A-copy (if (blas-matrix-compatiblep A cjob) A - (let ((*default-stride-ordering* :col-major)) - (t/copy! (,cla ,cla) A (t/zeros ,clx (dimensions A))))))) - (multiple-value-bind (lda op maj) (blas-matrix-compatiblep A-copy cjob) - (declare (ignore maj)) - (t/blas-gemv! ,cla alpha A-copy lda - x (aref (the index-store-vector (strides x)) 0) - beta - y (aref (the index-store-vector (strides y)) 0) - op))))) - `(t/gemv! ,cla alpha A x beta y cjob))) - y)) - (gemv! alpha A x beta y job)) - (t - (error "Don't know how to apply gemv! to classes ~a." (list cla clx cly)))))) +(define-tensor-method gemv! (alpha (A standard-tensor :input) (x standard-tensor :input) beta (y standard-tensor :output) &optional (job :n)) + `(let ((alpha (t/coerce ,(field-type (cl x)) alpha)) + (beta (t/coerce ,(field-type (cl x)) beta)) + (cjob (aref (symbol-name job) 0))) + (declare (type ,(field-type (cl x)) alpha beta) + (type character cjob)) + ,(recursive-append + (when (subtypep (cl x) 'blas-numeric-tensor) + `(if (call-fortran? A (t/l2-lb ,(cl a))) + (let ((A-copy (if (blas-matrix-compatiblep A cjob) A + (let ((*default-stride-ordering* :col-major)) + (t/copy! (,(cl a) ,(cl a)) A (t/zeros ,(cl x) (dimensions A))))))) + (multiple-value-bind (lda op maj) (blas-matrix-compatiblep A-copy cjob) + (declare (ignore maj)) + (t/blas-gemv! ,(cl a) alpha A-copy lda + x (aref (the index-store-vector (strides x)) 0) + beta + y (aref (the index-store-vector (strides y)) 0) + op))))) + `(t/gemv! ,(cl a) alpha A x beta y cjob))) + 'y) ;;---------------------------------------------------------------;; (defgeneric gemv (alpha A x beta y &optional job) (:documentation diff --git a/src/level-1/maker.lisp b/src/blas/maker.lisp similarity index 100% rename from src/level-1/maker.lisp rename to src/blas/maker.lisp diff --git a/src/level-1/realimag.lisp b/src/blas/realimag.lisp similarity index 100% rename from src/level-1/realimag.lisp rename to src/blas/realimag.lisp diff --git a/src/level-1/scal.lisp b/src/blas/scal.lisp similarity index 100% rename from src/level-1/scal.lisp rename to src/blas/scal.lisp diff --git a/src/level-1/sum.lisp b/src/blas/sum.lisp similarity index 100% rename from src/level-1/sum.lisp rename to src/blas/sum.lisp diff --git a/src/level-1/swap.lisp b/src/blas/swap.lisp similarity index 100% rename from src/level-1/swap.lisp rename to src/blas/swap.lisp diff --git a/src/level-1/trans.lisp b/src/blas/trans.lisp similarity index 100% rename from src/level-1/trans.lisp rename to src/blas/trans.lisp diff --git a/src/classes/numeric.lisp b/src/classes/numeric.lisp index 018fdc4..2f5c97a 100644 --- a/src/classes/numeric.lisp +++ b/src/classes/numeric.lisp @@ -100,7 +100,7 @@ (imagpart (imagpart element))) (format stream (if (zerop imagpart) "~11,5,,,,,'Eg" - "#C(~0,4,,,,,'Ee, ~0,4,,,,,'Ee)") + "#C(~11,5,,,,,'Eg, ~11,5,,,,,'Eg)") realpart imagpart))) ;; (defleaf complex-tensor (complex-numeric-tensor) ()) diff --git a/src/foreign-core/blas.lisp b/src/foreign-core/blas.lisp index 2e1f57c..202f555 100644 --- a/src/foreign-core/blas.lisp +++ b/src/foreign-core/blas.lisp @@ -28,6 +28,24 @@ (in-package #:matlisp-blas) +;; (defparameter *f77-floats* '(:single-float :double-float :complex-single-float :complex-double-float)) + +;; (defmacro generate-bindings (fname) +;; (let ((defs (parse-fortran-file fname))) +;; `(eval-every +;; ,@(mapcar #'(lambda (x) +;; `(def-fortran-routine ,(first x) ,(second x) +;; ,@(mapcar #'(lambda (y) +;; (let ((type (cadr y)) +;; (var (car y))) +;; (if (and (consp type) (eql (first type) '*) (member (second type) *f77-floats*)) +;; (list var (append type (list :inc (intern (string+ "HEAD-" (symbol-name var)))))) +;; y))) +;; (third x)))) +;; defs)))) + +;; (generate-bindings "/home/neptune/devel/matlisp/blas/blas.f") + (def-fortran-routine daxpy :void " Syntax commit 4ae0303bba3df2d7d9b3470181947a0056d72e1b Author: Akshay Srinivasan <aks...@gm...> Date: Tue Feb 18 20:51:23 2014 -0800 Moved L1 functions to use define-tensor-method. diff --git a/src/base/tensor-template.lisp b/src/base/tensor-template.lisp index 7c22736..ad93e54 100644 --- a/src/base/tensor-template.lisp +++ b/src/base/tensor-template.lisp @@ -147,11 +147,30 @@ (lst (assoc ',(mapcar #'(lambda (x) (if (consp x) (cadr x) t)) args) (cdr (gethash ',name *generated-methods*)) :test #'list-eq))) (assert lst nil "Method table missing from *generated-methods* !") (setf (cdr lst) (list* method (cdr lst)))) - (,name ,@(mapcar #'(lambda (x) (if (consp x) (car x) x)) args))) + (,name ,@(mapcar #'(lambda (x) (if (consp x) (car x) x)) (remove-if #'(lambda (x) (and (not (consp x)) (char= (aref (symbol-name x) 0) #\&))) args)))) ((and (every #'(lambda (,x) (eql ,x (car ,oclasses))) ,oclasses) (or (null ,oclasses) (coerceable? (cclass-max ,iclasses) (car ,oclasses)))) (let* ((clm (or (car ,oclasses) (cclass-max ,iclasses))) ,@(mapcar #'(lambda (x) `(,x (lazy-coerce ,x clm))) inputs)) - (,name ,@(mapcar #'(lambda (x) (if (consp x) (car x) x)) args)))) + (,name ,@(mapcar #'(lambda (x) (if (consp x) (car x) x)) (remove-if #'(lambda (x) (and (not (consp x)) (char= (aref (symbol-name x) 0) #\&))) args))))) (t (error "Don't know how to apply ~a to classes ~a, ~a." ',name ,iclasses ,oclasses))))))))) + + +;; + +;; (defgeneric testg (a)) +;; (define-tensor-method testg ((x standard-tensor :output)) +;; `(t/copy! (t ,(cl x)) 1 x) +;; 'x) + +;; (defgeneric axpy-test (alpha x y)) + +;; (define-tensor-method axpy-test (alpha (x standard-tensor :input) (y standard-tensor :output)) +;; `(let ((alpha (t/coerce ,(field-type (cl x)) alpha))) +;; (declare (type ,(field-type (cl x)) alpha)) +;; ,(recursive-append +;; (when (subtypep (cl x) 'blas-numeric-tensor) +;; `(if-let (strd (and (call-fortran? x (t/l1-lb ,(cl x))) (blas-copyablep x y))) +;; (t/blas-axpy! ,(cl x) alpha x (first strd) y (second strd)))) +;; `(t/axpy! ,(cl x) alpha x y)))) diff --git a/src/level-1/axpy.lisp b/src/level-1/axpy.lisp index ee782f7..2e28522 100644 --- a/src/level-1/axpy.lisp +++ b/src/level-1/axpy.lisp @@ -104,62 +104,25 @@ (assert (lvec-eq (dimensions x) (dimensions y) #'=) nil 'tensor-dimension-mismatch))) -;; - -;; (defgeneric testg (a)) -;; (define-tensor-method testg ((x standard-tensor :output)) -;; `(t/copy! (t ,(cl x)) 1 x) -;; 'x) - -;; (defgeneric axpy-test (alpha x y)) - -;; (define-tensor-method axpy-test (alpha (x standard-tensor :input) (y standard-tensor :output)) -;; `(let ((alpha (t/coerce ,(field-type (cl x)) alpha))) -;; (declare (type ,(field-type (cl x)) alpha)) -;; ,(recursive-append -;; (when (subtypep (cl x) 'blas-numeric-tensor) -;; `(if-let (strd (and (call-fortran? x (t/l1-lb ,(cl x))) (blas-copyablep x y))) -;; (t/blas-axpy! ,(cl x) alpha x (first strd) y (second strd)))) -;; `(t/axpy! ,(cl x) alpha x y)))) - -(defmethod axpy! (alpha (x standard-tensor) (y standard-tensor)) - (let ((clx (class-name (class-of x))) - (cly (class-name (class-of y)))) - (assert (and (member clx *tensor-type-leaves*) - (member cly *tensor-type-leaves*)) - nil 'tensor-abstract-class :tensor-class (list clx cly)) - (cond - ((eq clx cly) - (compile-and-eval - `(defmethod axpy! ((alpha t) (x ,clx) (y ,cly)) - (let ((alpha (t/coerce ,(field-type clx) alpha))) - (declare (type ,(field-type clx) alpha)) - ,(recursive-append - (when (subtypep clx 'blas-numeric-tensor) - `(if-let (strd (and (call-fortran? x (t/l1-lb ,clx)) (blas-copyablep x y))) - (t/blas-axpy! ,clx alpha x (first strd) y (second strd)))) - `(t/axpy! ,clx alpha x y)) - y))) - (axpy! alpha x y)) - (t - (error "Don't know how to apply axpy! to classes ~a, ~a." clx cly))))) - -(defmethod axpy! (alpha (x (eql nil)) (y standard-tensor)) - (let ((cly (class-name (class-of y)))) - (assert (member cly *tensor-type-leaves*) - nil 'tensor-abstract-class :tensor-class cly) - (compile-and-eval - `(defmethod axpy! ((alpha t) (x (eql nil)) (y ,cly)) - (let ((alpha (t/coerce ,(field-type cly) alpha))) - (declare (type ,(field-type cly) alpha)) - ,(recursive-append - (when (subtypep cly 'blas-numeric-tensor) - `(if-let (strd (and (call-fortran? y (t/l1-lb ,cly)) (consecutive-storep y))) - (t/blas-axpy! ,cly alpha nil nil y strd))) - `(t/axpy! ,cly alpha nil y)) - y))) - (axpy! alpha nil y))) - +(define-tensor-method axpy! (alpha (x standard-tensor :input) (y standard-tensor :output)) + `(let ((alpha (t/coerce ,(field-type (cl x)) alpha))) + (declare (type ,(field-type (cl x)) alpha)) + ,(recursive-append + (when (subtypep (cl x) 'blas-numeric-tensor) + `(if-let (strd (and (call-fortran? x (t/l1-lb ,(cl x))) (blas-copyablep x y))) + (t/blas-axpy! ,(cl x) alpha x (first strd) y (second strd)))) + `(t/axpy! ,(cl x) alpha x y)) + y)) + +(define-tensor-method axpy! (alpha (x (eql nil)) (y standard-tensor :output)) + `(let ((alpha (t/coerce ,(field-type (cl y)) alpha))) + (declare (type ,(field-type (cl y)) alpha)) + ,(recursive-append + (when (subtypep (cl y) 'blas-numeric-tensor) + `(if-let (strd (and (call-fortran? y (t/l1-lb ,(cl y))) (consecutive-storep y))) + (t/blas-axpy! ,(cl y) alpha nil nil y strd))) + `(t/axpy! ,(cl y) alpha nil y)) + y)) ;; (defgeneric axpy (alpha x y) (:documentation @@ -186,5 +149,7 @@ (axpy! alpha x (copy y)))) (defmethod axpy (alpha (x standard-tensor) (y (eql nil))) - (let ((tmp (zeros (dimensions x) (class-of x)))) - (axpy! alpha x tmp))) + (axpy! alpha x (zeros (dimensions x) (class-of x)))) + +(defmethod axpy ((alpha complex) (x real-numeric-tensor) (y (eql nil))) + (axpy! alpha x (zeros (dimensions x) 'complex-tensor))) diff --git a/src/level-1/dot.lisp b/src/level-1/dot.lisp index f3d136a..9de26de 100644 --- a/src/level-1/dot.lisp +++ b/src/level-1/dot.lisp @@ -117,46 +117,28 @@ (* (conjugate x) y) (* x y))) -(defmethod dot ((x standard-tensor) (y standard-tensor) &optional (conjugate-p t)) - (let ((clx (class-name (class-of x))) - (cly (class-name (class-of y)))) - (assert (and (member clx *tensor-type-leaves*) - (member cly *tensor-type-leaves*)) - nil 'tensor-abstract-class :tensor-class (list clx cly)) - (cond - ((eq clx cly) - (compile-and-eval - `(defmethod dot ((x ,clx) (y ,cly) &optional (conjugate-p t)) - ,(recursive-append - (when (subtypep clx 'blas-numeric-tensor) - `(if (call-fortran? x (t/l1-lb ,clx)) - (if conjugate-p - (t/blas-dot ,clx x y t) - (t/blas-dot ,clx x y nil)))) - `(if conjugate-p - ;;Please do your checks before coming here. - (t/dot ,clx x y t) - (t/dot ,clx x y nil))))) - (dot x y conjugate-p)) - (t - (error "Don't know how to compute the dot product of ~a , ~a." clx cly))))) +(define-tensor-method dot ((x standard-tensor :input) (y standard-tensor :input) &optional (conjugate-p t)) + (recursive-append + (when (subtypep (cl x) 'blas-numeric-tensor) + `(if (call-fortran? x (t/l1-lb ,(cl x))) + (if conjugate-p + (t/blas-dot ,(cl x) x y t) + (t/blas-dot ,(cl x) x y nil)))) + `(if conjugate-p + ;;Please do your checks before coming here. + (t/dot ,(cl x) x y t) + (t/dot ,(cl x) x y nil)))) -(defmethod dot ((x standard-tensor) (y t) &optional (conjugate-p t)) - (let ((clx (class-name (class-of x)))) - (assert (member clx *tensor-type-leaves*) - nil 'tensor-abstract-class :tensor-class (list clx)) - (compile-and-eval - `(defmethod dot ((x ,clx) (y t) &optional (conjugate-p t)) - (let ((y (t/coerce ,(field-type clx) y))) - (declare (type ,(field-type clx) y)) - ,(recursive-append - (when (subtypep clx 'blas-numeric-tensor) - `(if (call-fortran? x (t/l1-lb ,clx)) - (if conjugate-p - (t/blas-dot ,clx x y t t) - (t/blas-dot ,clx x y nil t)))) - `(if conjugate-p - ;;Please do your checks before coming here. - (t/dot ,clx x y t t) - (t/dot ,clx x y nil t)))))) - (dot x y conjugate-p))) +(define-tensor-method dot ((x standard-tensor :input) (y t) &optional (conjugate-p t)) + `(let ((y (t/coerce ,(field-type (cl x)) y))) + (declare (type ,(field-type (cl x)) y)) + ,(recursive-append + (when (subtypep (cl x) 'blas-numeric-tensor) + `(if (call-fortran? x (t/l1-lb ,(cl x))) + (if conjugate-p + (t/blas-dot ,(cl x) x y t t) + (t/blas-dot ,(cl x) x y nil t)))) + `(if conjugate-p + ;;Please do your checks before coming here. + (t/dot ,(cl x) x y t t) + (t/dot ,(cl x) x y nil t))))) diff --git a/src/level-1/realimag.lisp b/src/level-1/realimag.lisp index 498f93d..c7a7a67 100644 --- a/src/level-1/realimag.lisp +++ b/src/level-1/realimag.lisp @@ -42,14 +42,14 @@ If TENSOR is a scalar, returns its real part. " (etypecase tensor - (real-tensor tensor) - (complex-tensor (let ((*check-after-initializing?* nil)) - (make-instance 'real-tensor - :parent-tensor tensor :store (store tensor) - :dimensions (dimensions tensor) - :strides (map 'index-store-vector #'(lambda (x) (* 2 x)) (the index-store-vector (strides tensor))) - :head (the index-type (* 2 (head tensor)))))) - (number (realpart tensor)))) + ((or real-tensor sreal-tensor) tensor) + ((or complex-tensor scomplex-tensor) (let ((*check-after-initializing?* nil)) + (make-instance (if (typep tensor 'complex-tensor) 'real-tensor 'sreal-tensor) + :parent-tensor tensor :store (store tensor) + :dimensions (dimensions tensor) + :strides (map 'index-store-vector #'(lambda (x) (* 2 x)) (the index-store-vector (strides tensor))) + :head (the index-type (* 2 (head tensor)))))) + (number (cl:realpart tensor)))) (definline tensor-imagpart~ (tensor) " @@ -65,13 +65,13 @@ If TENSOR is a scalar, returns its real part. " (etypecase tensor - (real-tensor tensor) - (complex-tensor (let ((*check-after-initializing?* nil)) - (make-instance 'real-tensor - :parent-tensor tensor :store (store tensor) - :dimensions (dimensions tensor) - :strides (map 'index-store-vector #'(lambda (x) (* 2 x)) (the index-store-vector (strides tensor))) - :head (the index-type (1+ (* 2 (head tensor))))))) + ((or real-tensor sreal-tensor) tensor) + ((or complex-tensor scomplex-tensor) (let ((*check-after-initializing?* nil)) + (make-instance (if (typep tensor 'complex-tensor) 'real-tensor 'sreal-tensor) + :parent-tensor tensor :store (store tensor) + :dimensions (dimensions tensor) + :strides (map 'index-store-vector #'(lambda (x) (* 2 x)) (the index-store-vector (strides tensor))) + :head (the index-type (1+ (* 2 (head tensor))))))) (number (realpart tensor)))) (definline tensor-realpart (tensor) diff --git a/src/level-1/scal.lisp b/src/level-1/scal.lisp index eb89d74..5ef3288 100644 --- a/src/level-1/scal.lisp +++ b/src/level-1/scal.lisp @@ -93,97 +93,24 @@ (assert (very-quickly (lvec-eq (the index-store-vector (dimensions x)) (the index-store-vector (dimensions y)) #'=)) nil 'tensor-dimension-mismatch))) -(defmethod scal! ((x standard-tensor) (y standard-tensor)) - (let ((clx (class-name (class-of x))) - (cly (class-name (class-of y)))) - (assert (and (member clx *tensor-type-leaves*) - (member cly *tensor-type-leaves*)) - nil 'tensor-abstract-class :tensor-class (list clx cly)) - (cond - ((eq clx cly) - (compile-and-eval - `(defmethod scal! ((x ,clx) (y ,cly)) - ,(recursive-append - (when (subtypep clx 'blas-numeric-tensor) - `(if-let (strd (and (call-fortran? x (t/l1-lb ,clx)) (blas-copyablep x y))) - (t/blas-scdi! ,clx x (first strd) y (second strd) t))) - `(t/scdi! ,clx x y :scal? t :numx? nil)) - y)) - (scal! x y)) - (t - (error "Don't know how to apply scal! to classes ~a, ~a." clx cly))))) - -(defmethod scal! ((x t) (y standard-tensor)) - (let ((cly (class-name (class-of y)))) - (assert (member cly *tensor-type-leaves*) - nil 'tensor-abstract-class :tensor-class cly) - (compile-and-eval - `(defmethod scal! ((x t) (y ,cly)) - (let ((x (t/coerce ,(field-type cly) x))) - (declare (type ,(field-type cly) x)) - ,(recursive-append - (when (subtypep cly 'blas-numeric-tensor) - `(if-let (strd (and (call-fortran? y (t/l1-lb ,cly)) (consecutive-storep y))) - (t/blas-scdi! ,cly x nil y strd t))) - `(t/scdi! ,cly x y :scal? t :numx? t)) - y))) - (scal! x y))) - -;;These should've auto-generated. -(defgeneric div! (alpha x) - (:documentation - " - Syntax - ====== - (DIV! alpha x) - - Purpose - ======= - X <- X ./ alpha - - Yes the calling order is twisted. -") - (:method :before ((x standard-tensor) (y standard-tensor)) - (assert (very-quickly (lvec-eq (the index-store-vector (dimensions x)) (the index-store-vector (dimensions y)) #'=)) nil - 'tensor-dimension-mismatch))) - -(defmethod div! ((x standard-tensor) (y standard-tensor)) - (let ((clx (class-name (class-of x))) - (cly (class-name (class-of y)))) - (assert (and (member clx *tensor-type-leaves*) - (member cly *tensor-type-leaves*)) - nil 'tensor-abstract-class :tensor-class (list clx cly)) - (cond - ((eq clx cly) - (compile-and-eval - `(defmethod div! ((x ,clx) (y ,cly)) - ,(recursive-append - (when (subtypep clx 'blas-numeric-tensor) - `(if-let (strd (and (call-fortran? x (t/l1-lb ,clx)) (blas-copyablep x y))) - (t/blas-scdi! ,clx x (first strd) y (second strd) nil))) - `(t/scdi! ,clx x y :scal? nil :numx? nil)) - y)) - (div! x y)) - (t - (error "Don't know how to apply div! to classes ~a, ~a." clx cly))))) - -(defmethod div! ((x t) (y standard-tensor)) - (let ((cly (class-name (class-of y)))) - (assert (member cly *tensor-type-leaves*) - nil 'tensor-abstract-class :tensor-class cly) - (compile-and-eval - `(defmethod div! ((x t) (y ,cly)) - (let ((x (t/coerce ,(field-type cly) x))) - (declare (type ,(field-type cly) x)) - ,(recursive-append - (when (subtypep cly 'blas-numeric-tensor) - `(if-let (strd (and (call-fortran? y (t/l1-lb ,cly)) (consecutive-storep y))) - (t/blas-scdi! ,cly x nil y strd nil))) - `(t/scdi! ,cly x y :scal? nil :numx? t)) - y))) - (div! x y))) +(define-tensor-method scal! ((x standard-tensor :input) (y standard-tensor :output)) + (recursive-append + (when (subtypep (cl x) 'blas-numeric-tensor) + `(if-let (strd (and (call-fortran? x (t/l1-lb ,(cl x))) (blas-copyablep x y))) + (t/blas-scdi! ,(cl x) x (first strd) y (second strd) t))) + `(t/scdi! ,(cl x) x y :scal? t :numx? nil)) + 'y) + +(define-tensor-method scal! ((x t) (y standard-tensor :output)) + `(let ((x (t/coerce ,(field-type (cl y)) x))) + (declare (type ,(field-type (cl y)) x)) + ,(recursive-append + (when (subtypep (cl y) 'blas-numeric-tensor) + `(if-let (strd (and (call-fortran? y (t/l1-lb ,(cl y))) (consecutive-storep y))) + (t/blas-scdi! ,(cl y) x nil y strd t))) + `(t/scdi! ,(cl y) x y :scal? t :numx? t)) + y)) -;; (defgeneric scal (alpha x) (:documentation " @@ -204,7 +131,44 @@ (scal! alpha (copy x))) ;;TODO: There is an issue here when x is not coerceable into the tensor class of alpha (:method ((alpha standard-tensor) (x t)) - (scal! alpha (copy! x (zeros (dimensions alpha) (class-of alpha)))))) + ;;We assume commutation of course. + (scal! x (copy alpha)))) + +;;These should've been auto-generated. +(defgeneric div! (alpha x) + (:documentation + " + Syntax + ====== + (DIV! alpha x) + + Purpose + ======= + X <- X ./ alpha + + Yes the calling order is twisted. +") + (:method :before ((x standard-tensor) (y standard-tensor)) + (assert (very-quickly (lvec-eq (the index-store-vector (dimensions x)) (the index-store-vector (dimensions y)) #'=)) nil + 'tensor-dimension-mismatch))) + +(define-tensor-method div! ((x standard-tensor :input) (y standard-tensor :output)) + (recursive-append + (when (subtypep (cl x) 'blas-numeric-tensor) + `(if-let (strd (and (call-fortran? x (t/l1-lb ,(cl x))) (blas-copyablep x y))) + (t/blas-scdi! ,(cl x) x (first strd) y (second strd) nil))) + `(t/scdi! ,(cl x) x y :scal? nil :numx? nil)) + 'y) + +(define-tensor-method div! ((x t) (y standard-tensor :output)) + `(let ((x (t/coerce ,(field-type (cl y)) x))) + (declare (type ,(field-type (cl y)) x)) + ,(recursive-append + (when (subtypep (cl y) 'blas-numeric-tensor) + `(if-let (strd (and (call-fortran? y (t/l1-lb ,(cl y))) (consecutive-storep y))) + (t/blas-scdi! ,(cl y) x nil y strd nil))) + `(t/scdi! ,(cl y) x y :scal? nil :numx? t)) + y)) (defgeneric div (x y) (:documentation " diff --git a/src/level-1/sum.lisp b/src/level-1/sum.lisp index 7da2868..9e08752 100644 --- a/src/level-1/sum.lisp +++ b/src/level-1/sum.lisp @@ -60,4 +60,3 @@ (declare (ignore axis)) (t/sum ,clx x nil)))) (sum! x y axis))) - diff --git a/src/utilities/string.lisp b/src/utilities/string.lisp index aede8fb..3cb393a 100644 --- a/src/utilities/string.lisp +++ b/src/utilities/string.lisp @@ -30,7 +30,8 @@ returning two values: the string and the number of bytes read." (sb-posix:close fd)) (values data fsize))) - (definline split-seq (test seq &key max-cuts) + (declaim (inline split-seq)) + (defun split-seq (test seq &key max-cuts) "Split a sequence, wherever the given character occurs." (let ((split-list nil) (split-count 0) (deletes nil)) (labels ((left-split (prev i) commit 2222db6683c9dbf031cd4db8db5214efe60b6d66 Author: Akshay Srinivasan <aks...@gm...> Date: Tue Feb 18 19:50:24 2014 -0800 Added more types into the F77 parser. diff --git a/packages.lisp b/packages.lisp index 97b776d..064342e 100644 --- a/packages.lisp +++ b/packages.lisp @@ -122,7 +122,7 @@ (:documentation "Fortran foreign function interface")) (defpackage "MATLISP-BLAS" - (:use #:common-lisp #:matlisp-ffi) + (:use #:common-lisp #:matlisp-ffi #:matlisp-utilities) (:export ;;BLAS Level 1 ;;------------ diff --git a/src/ffi/f77-parser.lisp b/src/ffi/f77-parser.lisp index 0a916be..f26b033 100644 --- a/src/ffi/f77-parser.lisp +++ b/src/ffi/f77-parser.lisp @@ -40,7 +40,7 @@ line continuations. line)) ;; (defparameter *%f77.typemap* - '((("character") :char) + '((("character") :character) (("character*") :string) (("character*1") :string) (("character*6") :string) @@ -52,6 +52,7 @@ line continuations. (("complex*16") :complex-double-float) (("external") (* :void)) (("dimension") nil) + (("logical") :integer) (("none") :void))) ;; (defun %f77.type (line) @@ -98,4 +99,3 @@ line continuations. (when (or (member "function" line :test #'string=) (member "subroutine" line :test #'string=)) (push (parse-procedure line) defns)))))) - commit 6c30013f4baa53a1b9fba64854c5c1e5cae44809 Author: Akshay Srinivasan <aks...@gm...> Date: Mon Feb 17 18:43:12 2014 -0800 Added a fortran definition parser. Fixed a bunch of bugs. diff --git a/packages.lisp b/packages.lisp index d492329..97b776d 100644 --- a/packages.lisp +++ b/packages.lisp @@ -116,7 +116,7 @@ #:foreign-vector #:make-foreign-vector #:foreign-vector-p #:fv-ref #:fv-pointer #:fv-size #:fv-type ;;Interface functions - #:def-fortran-routine + #:def-fortran-routine #:parse-fortran-file #:with-vector-data-addresses ) (:documentation "Fortran foreign function interface")) diff --git a/src/ffi/f77-ffi.lisp b/src/ffi/f77-ffi.lisp index e3a9843..5beee53 100644 --- a/src/ffi/f77-ffi.lisp +++ b/src/ffi/f77-ffi.lisp @@ -150,10 +150,13 @@ ((%f77.callback-type-p type) (let* ((callback-name (second type)) (field-gvar (intern (string+ "*" (symbol-name (gensym (symbol-name var))) "*"))) - (c-callback-code (%f77.def-fortran-callback field-gvar callback-name (third type) (cdddr type)))) + (c-callback-code (%f77.def-fortran-callback field-gvar callback-name (third type) (cdddr type)))) (nconsc callback-code `((defvar ,field-gvar nil) ,@c-callback-code)) (nconsc callback-args `((,field-gvar ,var))) (setq ffi-var `(cffi:callback ,callback-name)))) + ;; + ((and (listp type) (eq (car type) '*) (eq (cadr type) :void)) + (setq ffi-var var)) ;; Can't really enforce "style" when given an array. ;; Complex numbers do not latch onto this case, they ;; are passed by value. @@ -317,7 +320,7 @@ (when (and (%f77.output-p style) (not (eq type :string))) (nconsc return-vars `((,func-var ,ffi-var ,type))))))) - + (let ((retvar (gensym))) `( ,(recursive-append @@ -367,7 +370,7 @@ which copies the vector Y of N double-float's to the vector X. The function name in libblas.a is \"dcopy_\" (by Fortran convention). - (DEF-FORTRAN-ROUTINE DCOPY :void + (DEF-FORTRAN-ROUTINE DCOPY :void (N :integer :input) (X (* :double-float) :output) (INCX :integer :input) @@ -398,13 +401,13 @@ NAME Name of the lisp interface function that will be created. The name of the raw FFI will be derived from NAME via the function MAKE-FFI-NAME. The name of foreign function - (presumable a Fortran Function in an external library) + (presumable a Fortran Function in an external library) will be derived from NAME via MAKE-FORTRAN-NAME. RETURN-TYPE The type of data that will be returned by the external (presumably Fortran) function. - + (MEMBER RETURN-TYPE '(:VOID :INTEGER :SINGLE-FLOAT :DOUBLE-FLOAT :COMPLEX-SINGLE-FLOAT :COMPLEX-DOUBLE-FLOAT)) @@ -453,18 +456,18 @@ as one of the values from the lisp function NAME. - ** Note: In all 3 cases above the input VARIABLE will not be destroyed + ** Note: In all 3 cases above the input VARIABLE will not be destroyed or modified directly, a copy is taken and a pointer of that copy is passed to the (presumably Fortran) external routine. - (OR (* X) :INPUT Array entries are used but not modified. - :STRING) :OUTPUT Array entries need not be initialized on input, + (OR (* X) :INPUT Array entries are used but not modified. + :STRING) :OUTPUT Array entries need not be initialized on input, but will be *modified*. In addition, the array will be returned via the Lisp command VALUES from the lisp function NAME. :INPUT-OUTPUT Like :OUTPUT but initial values on entry may be used. - + The keyword :WORKSPACE is a nickname for :INPUT. The keywords :INPUT-OR-OUTPUT, :WORKSPACE-OUTPUT, :WORKSPACE-OR-OUTPUT are nicknames for :OUTPUT. @@ -546,7 +549,7 @@ (,hidden-var-name ,hack-return-type :output) ,@pars)) (setq hack-return-type :void))) - + `(progn (cffi:defcfun (,fortran-name ,lisp-name) ,(%f77.get-return-type hack-return-type) ,@(%f77.parse-fortran-parameters hack-body)) diff --git a/src/ffi/f77-parser.lisp b/src/ffi/f77-parser.lisp new file mode 100644 index 0000000..0a916be --- /dev/null +++ b/src/ffi/f77-parser.lisp @@ -0,0 +1,101 @@ +(in-package #:matlisp-ffi) + +;;Adapted from cl-blapack. +(defun %f77.tokenize (line) + (declare (type string line)) + (split-seq #'(lambda (c) + (cond + ((member c '(#\Space #\,)) t) + ((member c '(#\( #\))) :keep))) + line)) + +(defun %f77.splitlines (line) + " +Split lines of a Fortran 77 file, whilst removing comments, and taking care of +line continuations. +" + (declare (type string line)) + (split-seq (let ((newline-state 0) + (comment-state nil)) + #'(lambda (c) + (cond + ((member c '(#\Newline)) (setf newline-state 0 + comment-state nil) + :delete) + (newline-state + (incf newline-state) + (cond + ((and (= newline-state 1) (member c '(#\* #\C #\c))) + (setf comment-state t + newline-state nil) + :delete) + ((< newline-state 6) + (if (char= c #\Space) :delete + (progn (setf newline-state nil) + :right))) + ((= newline-state 6) + (progn (setf newline-state nil) + (if (member c '(#\Space #\0)) t :delete))))) + (comment-state :delete)))) + line)) +;; +(defparameter *%f77.typemap* + '((("character") :char) + (("character*") :string) + (("character*1") :string) + (("character*6") :string) + (("integer") :integer) + (("real") :single-float) + (("double" "precision") :double-float) + (("complex") :complex-single-float) + (("double" "complex") :complex-double-float) + (("complex*16") :complex-double-float) + (("external") (* :void)) + (("dimension") nil) + (("none") :void))) +;; +(defun %f77.type (line) + (when-let (type (find line *%f77.typemap* :test #'(lambda (x y) (every #'string= x (car y))))) + (list (cadr type) (nthcdr (length (car type)) line)))) + +(defun parse-fortran-file (fname) + (let ((lines (mapcar #'%f77.tokenize (%f77.splitlines (string-downcase (file->string fname)))))) + (labels ((pointerp (pos line) + (let ((lst (nthcdr (1+ pos) line))) + (when (and (consp lst) (every #'(lambda (x y) (if (eql y t) t (string= x y))) lst '("(" t ")"))) + (cadr lst)))) + (parse-procedure (line) + (let* ((func-name (if (string= (car line) "subroutine") + (cadr line) + (elt line (1+ (position "function" line :test #'string=))))) + (output-type (if (string= (car line) "subroutine") + '("none") + (subseq line 0 (position "function" line :test #'string=)))) + (arguments (mapcar #'(lambda (x) (list x nil nil)) (subseq line (1+ (position "(" line :test #'string=)) (position ")" line :test #'string=))))) + (do ((cline '("") (cond + ((null lines) (error "Cannot find END statement.")) + ((string= (caar lines) "end") (pop lines) nil) + (t (pop lines))))) + ((null cline)) + (when (member cline *%f77.typemap* :test #'(lambda (x y) (every #'string= x (car y)))) + (let ((type (%f77.type cline))) + (if (car type) + (mapcar #'(lambda (x) (when (and (not (second x)) (find (car x) (cadr type) :test #'string=)) + (setf (second x) (car type) + (third x) (pointerp (position (car x) (cadr type) :test #'string=) (cadr type))))) + arguments) + (mapcar #'(lambda (x) (when (and (not (third x)) (find (car x) (cadr type) :test #'string=)) + (setf (third x) (pointerp (position (car x) (cadr type) :test #'string=) (cadr type))))) + arguments))))) + (list (intern (string-upcase func-name)) (car (%f77.type output-type)) (mapcar #'(lambda (x) (list (intern (string-upcase (car x))) + (if (null (third x)) + (second x) + (list '* (second x))))) + arguments))))) + (do ((line '("") (pop lines)) + (defns nil)) + ((null line) defns) + (when (or (member "function" line :test #'string=) + (member "subroutine" line :test #'string=)) + (push (parse-procedure line) defns)))))) + diff --git a/src/utilities/functions.lisp b/src/utilities/functions.lisp index c131fa2..3688c36 100644 --- a/src/utilities/functions.lisp +++ b/src/utilities/functions.lisp @@ -36,7 +36,7 @@ (defun list-eq (a b &optional (test #'eq)) (if (or (atom a) (atom b)) (funcall test a b) - (and (list-eq (car a) (car b)) (list-eq (cdr a) (cdr b) test)))) + (and (list-eq (car a) (car b) test) (list-eq (cdr a) (cdr b) test)))) (defun remmeth (func spls &optional quals) (let ((meth (find-method func quals (mapcar #'(lambda (x) (if (consp x) x (find-class x))) spls) nil))) diff --git a/src/utilities/string.lisp b/src/utilities/string.lisp index 39b6510..aede8fb 100644 --- a/src/utilities/string.lisp +++ b/src/utilities/string.lisp @@ -30,36 +30,52 @@ returning two values: the string and the number of bytes read." (sb-posix:close fd)) (values data fsize))) - (defun split-seq (test seq &key (filter-empty? t) max-cuts from-end?) + (definline split-seq (test seq &key max-cuts) "Split a sequence, wherever the given character occurs." - (if (not from-end?) - (let ((split-list nil) - (split-count 0)) - (loop :for i :from 0 :to (length seq) - :with len := (length seq) - :with prev := 0 - :do (let ((cuts-exceeded? (and max-cuts (>= split-count max-cuts)))) - (when (or (= i len) cuts-exceeded? (funcall test (aref seq i))) - (let* ((str (subseq seq prev (if cuts-exceeded? len i)))) - (when (or cuts-exceeded? (< prev i) (not filter-empty?)) - (incf split-count) - (push str split-list)) - (setf prev (1+ i)))) - (when cuts-exceeded? (return)))) - (values (reverse split-list) (1- split-count))) - (let ((split-list nil) - (split-count 0)) - (loop :for i :from (1- (length seq)) :downto -1 - :with prev := (length seq) - :do (let ((cuts-exceeded? (and max-cuts (>= split-count max-cuts)))) - (when (or (< i 0) cuts-exceeded? (funcall test (aref seq i))) - (let ((str (subseq seq (if cuts-exceeded? 0 (1+ i)) prev))) - (when (or cuts-exceeded? (< (1+ i) prev) (not filter-empty?)) - (incf split-count) - (push str split-list)) - (setf prev i))) - (when cuts-exceeded? (return)))) - (values split-list split-count)))) + (let ((split-list nil) (split-count 0) (deletes nil)) + (labels ((left-split (prev i) + (if (not deletes) + (when (< prev i) + (push (subseq seq prev i) split-list) + (incf split-count)) + (do ((dlst deletes (or (cdr dlst) (cons (1- prev) t))) + (pele i (car dlst)) + (ret nil)) + ((eql dlst t) (progn (setf deletes nil) + (when ret + (push (apply #'string+ ret) split-list) + (incf split-count)))) + (let ((ele (car dlst))) + (when (< (1+ ele) pele) + (push (subseq seq (1+ ele) pele) ret))))))) + (loop :for i :from 0 :to (length seq) + :with len := (length seq) + :with prev := 0 + :do (let ((cmd nil)) + (cond + ((or (= i len) (and max-cuts (>= split-count max-cuts))) + (left-split prev len) + (return)) + ((setf cmd (funcall test (aref seq i))) + (case cmd + (:left + (left-split prev (1+ i)) + (setf prev (1+ i))) + (:right + (left-split prev i) + (setf prev i)) + (:keep + (left-split prev i) + (push (string (aref seq i)) split-list) + (incf split-count) + (setf prev (1+ i))) + (:delete + (push i deletes)) + (t + (left-split prev i) + (setf prev (1+ i))))))))) + (values (nreverse split-list) (1- split-count)))) + ;; (defun splitlines (string) "Split the given string wherever the Carriage-return occurs." commit c248fe3323b34374070cb9df9a6d765a85e73b01 Author: Akshay Srinivasan <aks...@gm...> Date: Sun Feb 16 00:27:37 2014 -0800 Added a new define-tensor-macro, which takes care of coercion and assorted irritations. diff --git a/src/base/tensor-template.lisp b/src/base/tensor-template.lisp index 9543583..7c22736 100644 --- a/src/base/tensor-template.lisp +++ b/src/base/tensor-template.lisp @@ -86,3 +86,72 @@ (assert (null (cdr idx)) nil "given more than one index for linear-store") `(setf (aref (the ,(store-type sym) ,store) (the index-type ,(car idx))) (the ,(field-type sym) ,value))) ;; +;;A helper macro which takes of care of the class checking and stuff. +(defparameter *generated-methods* (make-hash-table)) + +(definline lazy-coerce (x out) + (if (typep x out) x + (copy x out))) + +(defun cclass-max (lst) + (let ((max nil)) + (loop :for ele :in lst + :do (when (or (null max) (and (coerceable? max ele) + (or (not (coerceable? ele max)) + (and (subtypep ele 'blas-numeric-tensor) (subtypep max 'blas-numeric-tensor) + (> (float-digits (coerce 0 (store-element-type ele))) + (float-digits (coerce 0 (store-element-type max)))))))) + (setf max ele))) + max)) + +(defmacro define-tensor-method (name (&rest args) &body body) + (let* ((inputs (mapcar #'car (remove-if-not #'(lambda (x) (and (consp x) (eql (third x) :input))) args))) + (outputs (mapcar #'car (remove-if-not #'(lambda (x) (and (consp x) (eql (third x) :output))) args))) + (iclsym (zipsym inputs)) + (oclsym (zipsym outputs))) + ;; + (multiple-value-bind (val exists?) (gethash name *generated-methods*) + (if exists? + (let ((type-meths (assoc (mapcar #'(lambda (x) (if (consp x) (cadr x) t)) args) (cdr val) :test #'list-eq))) + (if type-meths + (progn + (loop :for ele in (cdr type-meths) + :do (remove-method (symbol-function name) ele)) + (setf (cdr type-meths) nil)) + (setf (cdr val) (list* (list (mapcar #'(lambda (x) (if (consp x) (cadr x) t)) args)) (cdr val))))) + (setf (gethash name *generated-methods*) (list name (list (mapcar #'(lambda (x) (if (consp x) (cadr x) t)) args)))))) + ;; + (with-gensyms (x classes iclasses oclasses) + `(defmethod ,name (,@(mapcar #'(lambda (x) (if (consp x) (subseq x 0 2) x)) args)) + (let* (,@(mapcar #'(lambda (lst) `(,(car lst) (class-name (class-of ,(cadr lst))))) (append iclsym oclsym)) + (,iclasses (list ,@(mapcar #'car iclsym))) + (,oclasses (list ,@(mapcar #'car oclsym))) + (,classes (append ,iclasses ,oclasses))) + (labels ((generate-code (class) + (let ((args (mapcar #'(lambda (x) (if (and (consp x) (member (third x) '(:input :output))) + (list (car x) class) + x)) + '(,@args))) + (ebody (macrolet ((cl (,x) + (let ((slook '(,@(mapcar #'(lambda (x) `(,(cadr x) class)) iclsym) + ,@(mapcar #'(lambda (x) `(,(cadr x) class)) oclsym)))) + (or (cadr (assoc ,x slook)) (error "Can't find class of ~a" ,x))))) + (list ,@body)))) + `(defmethod ,',name (,@args) + ,@ebody)))) + (cond + ((every #'(lambda (,x) (eql ,x (car ,classes))) ,classes) + (assert (member (car ,classes) *tensor-type-leaves*) + nil 'tensor-abstract-class :tensor-class ,classes) + (let* ((method (compile-and-eval (generate-code (car ,classes)))) + (lst (assoc ',(mapcar #'(lambda (x) (if (consp x) (cadr x) t)) args) (cdr (gethash ',name *generated-methods*)) :test #'list-eq))) + (assert lst nil "Method table missing from *generated-methods* !") + (setf (cdr lst) (list* method (cdr lst)))) + (,name ,@(mapcar #'(lambda (x) (if (consp x) (car x) x)) args))) + ((and (every #'(lambda (,x) (eql ,x (car ,oclasses))) ,oclasses) + (or (null ,oclasses) (coerceable? (cclass-max ,iclasses) (car ,oclasses)))) + (let* ((clm (or (car ,oclasses) (cclass-max ,iclasses))) + ,@(mapcar #'(lambda (x) `(,x (lazy-coerce ,x clm))) inputs)) + (,name ,@(mapcar #'(lambda (x) (if (consp x) (car x) x)) args)))) + (t + (error "Don't know how to apply ~a to classes ~a, ~a." ',name ,iclasses ,oclasses))))))))) diff --git a/src/foreign-core/blas.lisp b/src/foreign-core/blas.lisp index d7dd57b..2e1f57c 100644 --- a/src/foreign-core/blas.lisp +++ b/src/foreign-core/blas.lisp @@ -28,7 +28,6 @@ (in-package #:matlisp-blas) - (def-fortran-routine daxpy :void " Syntax @@ -72,6 +71,16 @@ (incy :integer :input) ) +(def-fortran-routine saxpy :void + (n :integer :input) + (da :single-float :input) + (dx (* :single-float :inc head-x)) + (incx :integer :input) + (dy (* :single-float :inc head-y) :output) + (incy :integer :input) +) +;; + (def-fortran-routine dcopy :void " Syntax @@ -113,6 +122,15 @@ (incy :integer :input) ) +(def-fortran-routine scopy :void + (n :integer :input) + (dx (* :single-float :inc head-x)) + (incx :integer :input) + (dy (* :single-float :inc head-y) :output) + (incy :integer :input) +) +;; + (def-fortran-routine drot :void " Applies a plane rotation. @@ -245,6 +263,16 @@ (incy :integer :input) ) +(def-fortran-routine caxpy :void + (n :integer :input) + (za :complex-single-float) + (zx (* :complex-single-float :inc head-x)) + (incx :integer :input) + (zy (* :complex-single-float :inc head-y) :output) + (incy :integer :input) +) + +;; (def-fortran-routine zcopy :void " Syntax @@ -287,6 +315,15 @@ (incy :integer :input) ) +(def-fortran-routine ccopy :void + (n :integer :input) + (zx (* :complex-single-float :inc head-x)) + (incx :integer :input) + (zy (* :complex-single-float :inc head-y) :output) + (incy :integer :input) +) + +;; (def-fortran-routine zdscal :void " Syntax diff --git a/src/level-1/axpy.lisp b/src/level-1/axpy.lisp index 6e6f155..ee782f7 100644 --- a/src/level-1/axpy.lisp +++ b/src/level-1/axpy.lisp @@ -30,9 +30,13 @@ (deft/generic (t/blas-axpy-func #'subfieldp) sym ()) (deft/method t/blas-axpy-func (sym real-tensor) () 'daxpy) +(deft/method t/blas-axpy-func (sym sreal-tensor) () + 'saxpy) (deft/method t/blas-axpy-func (sym complex-tensor) () 'zaxpy) -;; +(deft/method t/blas-axpy-func (sym scomplex-tensor) () + 'caxpy) +;; (deft/generic (t/blas-axpy! #'subtypep) sym (a x st-x y st-y)) (deft/method t/blas-axpy! (sym blas-numeric-tensor) (a x st-x y st-y) (let ((apy? (null x))) @@ -100,6 +104,24 @@ (assert (lvec-eq (dimensions x) (dimensions y) #'=) nil 'tensor-dimension-mismatch))) +;; + +;; (defgeneric testg (a)) +;; (define-tensor-method testg ((x standard-tensor :output)) +;; `(t/copy! (t ,(cl x)) 1 x) +;; 'x) + +;; (defgeneric axpy-test (alpha x y)) + +;; (define-tensor-method axpy-test (alpha (x standard-tensor :input) (y standard-tensor :output)) +;; `(let ((alpha (t/coerce ,(field-type (cl x)) alpha))) +;; (declare (type ,(field-type (cl x)) alpha)) +;; ,(recursive-append +;; (when (subtypep (cl x) 'blas-numeric-tensor) +;; `(if-let (strd (and (call-fortran? x (t/l1-lb ,(cl x))) (blas-copyablep x y))) +;; (t/blas-axpy! ,(cl x) alpha x (first strd) y (second strd)))) +;; `(t/axpy! ,(cl x) alpha x y)))) + (defmethod axpy! (alpha (x standard-tensor) (y standard-tensor)) (let ((clx (class-name (class-of x))) (cly (class-name (class-of y)))) diff --git a/src/level-1/copy.lisp b/src/level-1/copy.lisp index 736a40c..12c6b41 100644 --- a/src/level-1/copy.lisp +++ b/src/level-1/copy.lisp @@ -30,8 +30,12 @@ (deft/generic (t/blas-copy-func #'subfieldp) sym ()) (deft/method t/blas-copy-func (sym real-tensor) () 'dcopy) +(deft/method t/blas-copy-func (sym sreal-tensor) () + 'scopy) (deft/method t/blas-copy-func (sym complex-tensor) () 'zcopy) +(deft/method t/blas-copy-func (sym scomplex-tensor) () + 'ccopy) ;; (deft/generic (t/blas-copy! #'subtypep) sym (x st-x y st-y)) (deft/method t/blas-copy! (sym blas-numeric-tensor) (x st-x y st-y) commit 17a8a5233aa62740a17e8049835976f7a18e3d26 Author: Akshay Srinivasan <aks...@gm...> Date: Sun Feb 16 00:25:48 2014 -0800 Updated packages.lisp. diff --git a/packages.lisp b/packages.lisp index 21c0a96..d492329 100644 --- a/packages.lisp +++ b/packages.lisp @@ -77,7 +77,7 @@ #:cut-cons-chain! #:slot-values #:remmeth #:recursive-append #:unquote-args #:flatten - #:format-to-string #:string+ + #:format-to-string #:string+ #:file->string #:split-seq #:splitlines #:linear-array-type #:list-dimensions #:lvec-foldl #:lvec-foldr #:lvec-max #:lvec-min #:lvec-eq @@ -129,9 +129,13 @@ ;;Real-double #:ddot #:dnrm2 #:dasum #:dscal #:daxpy #:drot #:dswap #:dcopy #:idamax + ;;Real-single + #:saxpy #:scopy ;;Complex-double #:zdotc #:zdotu #:zdscal #:zscal #:zswap #:zcopy #:zaxpy #:dcabs1 #:dzasum #:dznrm2 #:izamax + ;;Complex-single + #:caxpy #:ccopy ;;BLAS Level 2 ;;------------ ;;Real-double commit 2e87492c26e3e9f0705efda698f6183d9c1425ea Author: Akshay Srinivasan <aks...@gm...> Date: Sun Feb 16 00:24:41 2014 -0800 Moved string functions into utilities. diff --git a/src/reader/loadsave.lisp b/src/reader/loadsave.lisp index c29cc64..dc9c986 100644 --- a/src/reader/loadsave.lisp +++ b/src/reader/loadsave.lisp @@ -1,45 +1,5 @@ (in-package #:matlisp) -#+(not :sbcl) -(defun file->string (path) - "Sucks up an entire file from PATH into a freshly-allocated string, -returning two values: the string and the number of bytes read." - (declare (optimize (safety 0) (speed 3))) - (with-open-file (s path :external-format :iso8859-1) - (let* ((len (file-length s)) - (data (make-array len :element-type 'standard-char))) - (values data (read-sequence data s))))) - -#+sbcl -(defun file->string (path) -"Sucks up an entire file from PATH into a freshly-allocated string, -returning two values: the string and the number of bytes read." - (let* ((fsize (with-open-file (s path) - (file-length s))) - (data (make-array fsize :element-type 'standard-char)) - (fd (sb-posix:open path 0))) - (unwind-protect (sb-posix:read fd (sb-sys:vector-sap data) fsize) - (sb-posix:close fd)) - (values data fsize))) -;; -(definline split-seq (test seq &optional (filter-empty? t)) - "Split a string, wherever the given character occurs." - (loop :for i :from (1- (length seq)) :downto -1 - :with prev := (length seq) - :with split-list := nil - :with split-count := 0 - :do (when (or (< i 0) (funcall test (aref seq i))) - (let ((str (subseq seq (1+ i) prev))) - (when (or (< (1+ i) prev) (not filter-empty?)) - (incf split-count) - (push str split-list)) - (setf prev i))) - :finally (return (values split-list split-count)))) -;; -(defun splitlines (string) - "Split the given string wherever the Carriage-return occurs." - (split-seq #'(lambda (x) (or (char= x #\Newline) (char= x #\Return))) string)) - ;; ;; (defmacro apply* ((&rest funcl) expr) ;; (let ((syms (zip (mapcar #'gensym funcl) funcl))) diff --git a/src/utilities/string.lisp b/src/utilities/string.lisp index 1833467..39b6510 100644 --- a/src/utilities/string.lisp +++ b/src/utilities/string.lisp @@ -7,4 +7,62 @@ (defun format-to-string (fmt &rest args) (apply #'format (append (list nil fmt) args))) + + #+(not :sbcl) + (defun file->string (path) + "Sucks up an entire file from PATH into a freshly-allocated string, +returning two values: the string and the number of bytes read." + (declare (optimize (safety 0) (speed 3))) + (with-open-file (s path :external-format :iso8859-1) + (let* ((len (file-length s)) + (data (make-array len :element-type 'standard-char))) + (values data (read-sequence data s))))) + + #+sbcl + (defun file->string (path) + "Sucks up an entire file from PATH into a freshly-allocated string, +returning two values: the string and the number of bytes read." + (let* ((fsize (with-open-file (s path) + (file-length s))) + (data (make-array fsize :element-type 'standard-char)) + (fd (sb-posix:open path 0))) + (unwind-protect (sb-posix:read fd (sb-sys:vector-sap data) fsize) + (sb-posix:close fd)) + (values data fsize))) + + (defun split-seq (test seq &key (filter-empty? t) max-cuts from-end?) + "Split a sequence, wherever the given character occurs." + (if (not from-end?) + (let ((split-list nil) + (split-count 0)) + (loop :for i :from 0 :to (length seq) + :with len := (length seq) + :with prev := 0 + :do (let ((cuts-exceeded? (and max-cuts (>= split-count max-cuts)))) + (when (or (= i len) cuts-exceeded? (funcall test (aref seq i))) + (let* ((str (subseq seq prev (if cuts-exceeded? len i)))) + (when (or cuts-exceeded? (< prev i) (not filter-empty?)) + (incf split-count) + (push str split-list)) + (setf prev (1+ i)))) + (when cuts-exceeded? (return)))) + (values (reverse split-list) (1- split-count))) + (let ((split-list nil) + (split-count 0)) + (loop :for i :from (1- (length seq)) :downto -1 + :with prev := (length seq) + :do (let ((cuts-exceeded? (and max-cuts (>= split-count max-cuts)))) + (when (or (< i 0) cuts-exceeded? (funcall test (aref seq i))) + (let ((str (subseq seq (if cuts-exceeded? 0 (1+ i)) prev))) + (when (or cuts-exceeded? (< (1+ i) prev) (not filter-empty?)) + (incf split-count) + (push str split-list)) + (setf prev i))) + (when cuts-exceeded? (return)))) + (values split-list split-count)))) + ;; + (defun splitlines (string) + "Split the given string wherever the Carriage-return occurs." + (split-seq #'(lambda (x) (or (char= x #\Newline) (char= x #\Return))) string)) + ) commit 4d63cc7ebed68cf20b1b4e83cbfb6b8815706a4e Author: Akshay Srinivasan <aks...@gm...> Date: Wed Feb 5 04:50:02 2014 -0800 Saving changes to sparse-tensor.lisp diff --git a/src/base/sparse-tensor.lisp b/src/base/sparse-tensor.lisp index a46c843..4119a3f 100644 --- a/src/base/sparse-tensor.lisp +++ b/src/base/sparse-tensor.lisp @@ -1,6 +1,9 @@ (in-package :matlisp) -;; +;;One may to do better than a Hash-table for this. +(defparameter *default-sparsity* 1/1000) +(defparameter *max-size* 10000) + (defclass coordinate-sparse-tensor (sparse-tensor) ((strides :initarg :strides :reader strides :type index-store-vector :documentation "Strides for accesing elements of the tensor."))) @@ -25,17 +28,17 @@ (unless (t/f= ,(field-type sym) ,val (t/fid+ ,(field-type sym))) (setf (gethash ,(car idx) ,store) (the ,(field-type sym) ,value)))))) +(deft/method t/store-type (sym coordinate-sparse-tensor) (&optional (size '*)) + 'hash-table) + (deft/method t/store-size (sym coordinate-sparse-tensor) (ele) `(hash-table-count ,ele)) (deft/method t/store-type (sym coordinate-sparse-tensor) (&optional (size '*)) 'hash-table) -(defparameter *default-sparsity* 1/1000) -(defparameter *max-size* 10000) - (deft/method t/compute-store-size (sym coordinate-sparse-tensor) (size) - `(max (min sb-impl::+min-hash-table-size+ (ceiling (/ ,size *default-sparsity*))) *max-size*)) + `(max (min sb-impl::+min-hash-table-size+ (ceiling (/ ,size *default-sparsity*))) *max-sparse-size*)) (defmethod head ((tensor coordinate-sparse-tensor)) 0) @@ -44,7 +47,6 @@ (deft/method t/field-type (sym real-sparse-tensor) () 'double-float) - ;; (defmethod ref ((tensor coordinate-sparse-tensor) &rest subscripts) (let ((clname (class-name (class-of tensor)))) @@ -65,61 +67,47 @@ (sto (store tensor))) (t/store-set ,clname (t/coerce ,(field-type clname) value) sto idx) (t/store-ref ,clname sto idx)))) - (setf (ref tensor subscripts) value))) + (setf (ref tensor (if (numberp (car subscripts)) subscripts (car subscripts))) value))) ;; (defclass compressed-sparse-matrix (sparse-tensor) - ((indices :initarg :strides :reader indices :type index-store-vector - :documentation "Strides for accesing elements of the tensor.") - (index-position :initarg :strides :reader index-position :type index-store-vector - :documentation "Strides for accesing elements of the tensor."))) - -(deft/method t/store-allocator (sym compressed-sparse-matrix) (size &optional initial-element) - (with-gensyms (sitm size-sym arr idx init) - (let ((type (macroexpand-1 `(t/store-element-type ,sym)))) - `(let*-typed ((,size-sym (t/compute-store-size ,sym (let ((,sitm ,size)) - (etypecase ,sitm - (index-type ,sitm) - (index-store-vector (lvec-foldr #'* (the index-store-vector ,sitm))) - (cons (reduce #'* ,sitm)))))) - ,@(when initial-element `((,init ,initial-element :type ,(field-type sym)))) - (,arr (make-array ,size-sym :element-type ',type :initial-element ,(if (subtypep type 'number) `(t/f... [truncated message content] |
From: Akshay S. <ak...@us...> - 2013-12-30 15:22:27
|
This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "matlisp". The branch, tensor has been updated via 7ddfe787e54e485108ff96839495e7a6f0d490c2 (commit) via 5cb54c25cb3aa489df3cfa6065f537d72d57cf19 (commit) via cf2de4f3c12aeb90062dd7afd82120aa3e5647a7 (commit) via 270890c43c5cfc819b9d551dcfe50167976af0e2 (commit) via fbb6af74f62783e94dd623de0bb6a50d3a9325c4 (commit) via ecbb04d8adfe7d75a4f6d064fcb0f14a66613556 (commit) via c0248c645d3d100b8f2e4b6569b730cd29e7589b (commit) via 32bce0a5847fc2b5ee46698b2e6e0a3a63466d4d (commit) via 24fca164d6b861365bdc977de64a29e6107da555 (commit) via 6dacaaaa8356ad476ac631eb95b93829a5f1e3f1 (commit) via 03fc1d7dafa1157eea84f9df3f0a24f1b4b240cd (commit) via 1d27fd93c94b99ff3f6fda26106e50c4d4cf1b01 (commit) via 23f3205a3cad2be9a270bd0dc4acb57d42d8dbb2 (commit) via 376d74de0a77839136869bcc27c5f877cb4a3bc8 (commit) via 953ce0f60f25157a4fc5b5d31403433aeb47e894 (commit) from 1f45e5ca07fb6ec6e83117fdb4a3ded5fa3e2b4f (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 7ddfe787e54e485108ff96839495e7a6f0d490c2 Author: Akshay Srinivasan <aks...@gm...> Date: Mon Dec 30 20:52:46 2013 +0530 Saving changes. diff --git a/matlisp.asd b/matlisp.asd index 8b57116..7e638b7 100644 --- a/matlisp.asd +++ b/matlisp.asd @@ -183,8 +183,8 @@ (:file "mtimesdivide"))) (:module "matlisp-reader" :pathname "reader" - :components (#+nil(:file "infix") - (:file "loadsave"))))) + :components ((:file "infix") + (:file "loadsave"))))) ;; (defclass f2cl-cl-source-file (asdf:cl-source-file) diff --git a/packages.lisp b/packages.lisp index 6d8868c..ca87d69 100644 --- a/packages.lisp +++ b/packages.lisp @@ -180,15 +180,14 @@ #:head #:strides #:store-size #:store #:parent-tensor ;;Sub-tensor - #:sub-tensor~ #:sub-tensor + #:subtensor~ #:subtensor ;;Store indexers #:store-indexing #:store-indexing-vec #:store-indexing-lst ;;Store accessors - #:tensor-store-ref - #:tensor-ref + #:ref #:store-ref ;;Type checking - #:tensor-type-p #:vector-p #:matrix-p #:square-p) + #:tensor-typep #:tensor-vectorp #:tensor-matrixp #:tensor-squarep) (:documentation "MATLISP routines")) ;;Transitioning to using the tensor-datastructures; eventually move things back to :matlisp diff --git a/src/reader/infix.lisp b/src/reader/infix.lisp index adaeabb..ecc72cc 100644 --- a/src/reader/infix.lisp +++ b/src/reader/infix.lisp @@ -255,7 +255,7 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (defparameter *version* "1.3 28-JUN-96") - (defparameter *print-infix-copyright* nil + (defparameter *print-infix-copyright* t "If non-NIL, prints a copyright notice upon loading this file.") (defun infix-copyright (&optional (stream *standard-output*)) @@ -280,6 +280,26 @@ (not (get :infix :dont-print-copyright))) (infix-copyright))) +;; Matlisp helpers +(defparameter *ref-list* '((cons elt) (array aref) (matlisp:standard-tensor matlisp:ref))) + +(defmacro generic-ref (x &rest args) + `(etypecase ,x + ,@(mapcar #'(lambda (l) `(,(car l) (,(cadr l) ,x ,@args))) *ref-list*))) + +(define-setf-expander generic-ref (x &rest args &environment env) + (multiple-value-bind (dummies vals newval setter getter) + (get-setf-expansion x env) + (with-gensyms (store) + (values (append dummies newval) + (append vals (list getter)) + `(,store) + (let ((arr (car newval))) + `(prog1 (etypecase ,arr + ,@(mapcar #'(lambda (l) `(,(car l) (setf (,(cadr l) ,arr ,@args) ,store))) *ref-list*)) + ,setter)) + `(generic-ref ,getter ,@args))))) + ;;; ******************************** ;;; Readtable ********************** ;;; ******************************** @@ -291,7 +311,6 @@ `(let ((*readtable* *normal-readtable*)) (error 'parser-error :message (format-to-string ,format-string ,@args)))) - (define-constant +blank-characters+ '(#\^m #\space #\tab #\return #\newline)) (define-constant +newline-characters+ '(#\newline #\^m #\linefeed #\return)) @@ -857,7 +876,7 @@ :infix (let ((indices (infix-read-delimited-list '\] '\, stream))) (if (null indices) (infix-error "No indices found in array reference.") - `(aref ,left ,@indices)))) + `(generic-ref ,left ,@indices)))) (define-character-tokenization #\( #'(lambda (stream char) commit 5cb54c25cb3aa489df3cfa6065f537d72d57cf19 Author: Akshay Srinivasan <aks...@gm...> Date: Sat Dec 28 18:29:48 2013 +0530 Added a preliminary version of foreign-tensor. diff --git a/src/classes/foreign.lisp b/src/classes/foreign.lisp new file mode 100644 index 0000000..c277850 --- /dev/null +++ b/src/classes/foreign.lisp @@ -0,0 +1,73 @@ +(in-package #:matlisp) + +(defclass foreign-numeric-tensor (blas-numeric-tensor) ()) + +(deft/method t/store-allocator (sym foreign-numeric-tensor) (size &optional initial-element) + (error "cannot allocate store for ~a" sym)) + +(deft/method t/store-type (sym foreign-numeric-tensor) (&optional size) + 'foreign-vector) +(deft/method t/store-size (sym foreign-numeric-tensor) (vec) + `(fv-size ,vec)) +(deft/method t/store-ref (sym foreign-numeric-tensor) (store idx) + `(the ,(field-type sym) (fv-ref ,store ,idx))) +(deft/method t/store-set (sym foreign-numeric-tensor) (value store idx) + `(setf (fv-ref ,store ,idx) (the ,(field-type sym) ,value))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defgeneric cl->cffi-type (type) + (:method (type) + (ecase type + (character :char) + (single-float :float) + (double-float :double) + (string :string) + (t (error 'unknown-token :token type + :message "Don't know how to convert type to CFFI.")))))) + +(deft/method with-field-element (sym foreign-numeric-tensor) (decl &rest body) + (destructuring-bind (var val &optional (count 1)) decl + (with-gensyms (idx size point) + (let ((type (cl->cffi-type (store-element-type sym)))) + `(let ((,size (t/compute-store-size ,sym ,count))) + (cffi:with-foreign-object (,point ,type ,size) + (let ((,var (make-foreign-vector :pointer ,point :type ,type :size ,size))) + ,@(when val + ;;No point rushing through this loop. + `((loop :for ,idx :from 0 :below ,size + :do (t/store-set ,sym ,val ,var ,idx)))) + (locally + ,@body)))))))) +;; +(defclass foreign-real-numeric-tensor (foreign-numeric-tensor real-numeric-tensor) ()) +(deft/method t/field-type (sym foreign-real-numeric-tensor) () + 'real) + +(defleaf foreign-real-tensor (foreign-real-numeric-tensor) ()) +(deft/method t/field-type (sym foreign-real-tensor) () + 'double-float) + +(defun make-foreign-real-tensor (dims pointer) + (let ((dims (make-index-store (etypecase dims + (vector (lvec->list dims)) + (cons dims) + (fixnum (list dims)))))) + (make-instance 'foreign-real-tensor + :dimensions dims + :store pointer + :strides (make-stride dims)))) + +(with-field-element foreign-real-tensor (fv 0d0 10) + (let ((tens (make-foreign-real-tensor (idxv 2 2) fv))) + (axpy! 1 nil tens) + (copy tens 'real-tensor))) + +;; +#+nil +(progn +(defclass foreign-complex-numeric-tensor (foreign-numeric-tensor complex-numeric-tensor) ()) +(deft/method t/field-type (sym foreign-complex-numeric-tensor) () + 'complex) + +(t/store-type foreign-real-tensor) +) diff --git a/src/ffi/foreign-vector.lisp b/src/ffi/foreign-vector.lisp index ef8c352..f6d6938 100644 --- a/src/ffi/foreign-vector.lisp +++ b/src/ffi/foreign-vector.lisp @@ -13,13 +13,13 @@ (format stream "~A " (fv-ref obj i))) (format stream ")")) -(defun fv-ref (x n) +(definline fv-ref (x n) (declare (type foreign-vector x) (type fixnum n)) (assert (< -1 n (fv-size x)) nil 'out-of-bounds-error :requested n :bound (fv-size x) :message "From inside fv-ref.") (cffi:mem-aref (fv-pointer x) (fv-type x) n)) -(defun (setf fv-ref) (value x n) +(definline (setf fv-ref) (value x n) (declare (type foreign-vector x) (type fixnum n)) (assert (< -1 n (fv-size x)) nil 'out-of-bounds-error :requested n :bound (fv-size x) :message "From inside fv-ref.") commit cf2de4f3c12aeb90062dd7afd82120aa3e5647a7 Author: Akshay Srinivasan <aks...@gm...> Date: Sat Dec 28 14:49:40 2013 +0530 Made t/store-allocator behave the way sanity would induce. diff --git a/src/base/template.lisp b/src/base/template.lisp index 5cd13dd..14d5fa7 100644 --- a/src/base/template.lisp +++ b/src/base/template.lisp @@ -106,20 +106,24 @@ ;; (deft/generic (t/store-allocator #'subtypep) sym (size &optional initial-element)) (deft/method t/store-allocator (sym standard-tensor) (size &optional initial-element) - (let ((size-sym (gensym)) - (type (macroexpand-1 `(t/store-element-type ,sym)))) - `(let ((,size-sym (t/compute-store-size ,sym ,size))) - (make-array ,size-sym :element-type ',type :initial-element ,(or initial-element (if (subtypep type 'number) `(t/fid+ ,type) nil)))))) + (with-gensyms (size-sym arr idx init) + (let ((type (macroexpand-1 `(t/store-element-type ,sym)))) + `(let*-typed ((,size-sym (t/compute-store-size ,sym ,size)) + ,@(when initial-element `((,init ,initial-element :type ,(field-type sym)))) + (,arr (make-array ,size-sym :element-type ',type :initial-element ,(if (subtypep type 'number) `(t/fid+ ,type) nil)) :type ,(store-type sym))) + ,@(when initial-element + `((very-quickly + (loop :for ,idx :from 0 :below ,size-sym + :do (t/store-set ,sym ,init ,arr ,idx))))) + ,arr)))) ;; (deft/generic (with-field-element #'subtypep) sym (decl &rest body)) (deft/method with-field-element (sym standard-tensor) (decl &rest body) - (destructuring-bind (var val) decl - `(let-typed ((,var (t/store-allocator ,sym 1) :type ,(store-type sym))) - (t/store-set ,sym ,val ,var 0) + (destructuring-bind (var init &optional (count 1)) decl + `(let-typed ((,var (t/store-allocator ,sym ,count ,init) :type ,(store-type sym))) (locally ,@body)))) ;; - (deft/generic (t/store-type #'subtypep) sym (&optional size)) (deft/method t/store-type (sym standard-tensor) (&optional (size '*)) `(simple-array ,(store-element-type sym) (,size))) commit 270890c43c5cfc819b9d551dcfe50167976af0e2 Author: Akshay Srinivasan <aks...@gm...> Date: Sat Dec 28 14:12:38 2013 +0530 Using with-field-element macro to make pointers for foreign functions. diff --git a/src/base/template.lisp b/src/base/template.lisp index b7fe327..5cd13dd 100644 --- a/src/base/template.lisp +++ b/src/base/template.lisp @@ -85,7 +85,6 @@ (macroexpand-1 `(t/field-type ,clname))) ;;This is useful for Eigenvalue decompositions (deft/generic (t/complexified-type #'subtypep) sym ()) - (defun complexified-type (type) (macroexpand-1 `(t/complexified-type ,type))) @@ -96,21 +95,30 @@ (defun store-element-type (clname) (macroexpand-1 `(t/store-element-type ,clname))) - +;; (deft/generic (t/compute-store-size #'subtypep) sym (size)) (deft/method t/compute-store-size (sym standard-tensor) (size) size) - +;; (deft/generic (t/store-size #'subtypep) sym (ele)) (deft/method t/store-size (sym standard-tensor) (ele) `(length ,ele)) - +;; (deft/generic (t/store-allocator #'subtypep) sym (size &optional initial-element)) (deft/method t/store-allocator (sym standard-tensor) (size &optional initial-element) (let ((size-sym (gensym)) (type (macroexpand-1 `(t/store-element-type ,sym)))) `(let ((,size-sym (t/compute-store-size ,sym ,size))) (make-array ,size-sym :element-type ',type :initial-element ,(or initial-element (if (subtypep type 'number) `(t/fid+ ,type) nil)))))) +;; +(deft/generic (with-field-element #'subtypep) sym (decl &rest body)) +(deft/method with-field-element (sym standard-tensor) (decl &rest body) + (destructuring-bind (var val) decl + `(let-typed ((,var (t/store-allocator ,sym 1) :type ,(store-type sym))) + (t/store-set ,sym ,val ,var 0) + (locally + ,@body)))) +;; (deft/generic (t/store-type #'subtypep) sym (&optional size)) (deft/method t/store-type (sym standard-tensor) (&optional (size '*)) diff --git a/src/level-1/axpy.lisp b/src/level-1/axpy.lisp index 73305ca..6e6f155 100644 --- a/src/level-1/axpy.lisp +++ b/src/level-1/axpy.lisp @@ -37,23 +37,20 @@ (deft/method t/blas-axpy! (sym blas-numeric-tensor) (a x st-x y st-y) (let ((apy? (null x))) (using-gensyms (decl (a x y)) - (with-gensyms (sto-x stp-x) + (with-gensyms (sto-x) `(let (,@decl) (declare (type ,sym ,@(unless apy? `(,x)) ,y) ,@(when apy? `((ignore ,x)))) - (let ((,sto-x ,(if apy? `(t/store-allocator ,sym 1) `(store ,x))) - (,stp-x ,(if apy? 0 st-x))) - (declare (type ,(store-type sym) ,sto-x) - (type index-type ,stp-x)) - ,@(when apy? - `((t/store-set ,sym (t/fid* ,(field-type sym)) ,sto-x 0))) - (,(macroexpand-1 `(t/blas-axpy-func ,sym)) - (the index-type (size ,y)) - (the ,(field-type sym) ,a) - ,sto-x ,stp-x - (the ,(store-type sym) (store ,y)) (the index-type ,st-y) - ,(if apy? 0 `(head ,x)) (head ,y)) - ,y)))))) + ,(recursive-append + (when apy? + `(with-field-element ,sym (,sto-x (t/fid* ,(field-type sym))))) + `(,(macroexpand-1 `(t/blas-axpy-func ,sym)) + (the index-type (size ,y)) + (the ,(field-type sym) ,a) + ,(if apy? sto-x `(the ,(store-type sym) (store ,x))) (the index-type ,(if apy? 0 st-x)) + (the ,(store-type sym) (store ,y)) (the index-type ,st-y) + ,(if apy? 0 `(head ,x)) (head ,y))) + ,y))))) (deft/generic (t/axpy! #'subtypep) sym (a x y)) (deft/method t/axpy! (sym standard-tensor) (a x y) diff --git a/src/level-1/copy.lisp b/src/level-1/copy.lisp index 0e4207b..c0815e6 100644 --- a/src/level-1/copy.lisp +++ b/src/level-1/copy.lisp @@ -37,23 +37,20 @@ (deft/method t/blas-copy! (sym blas-numeric-tensor) (x st-x y st-y) (let ((ncp? (null st-x))) (using-gensyms (decl (x y)) - (with-gensyms (sto-x stp-x) + (with-gensyms (sto-x) `(let (,@decl) (declare (type ,sym ,@(unless ncp? `(,x)) ,y) ,@(when ncp? `((type ,(field-type sym) ,x)))) - (let ((,sto-x ,(if ncp? `(t/store-allocator ,sym 1) `(store ,x))) - (,stp-x ,(if ncp? 0 st-x))) - (declare (type ,(store-type sym) ,sto-x) - (type index-type ,stp-x)) - ,@(when ncp? - `((t/store-set ,sym ,x ,sto-x 0))) - (,(macroexpand-1 `(t/blas-copy-func ,sym)) - (the index-type (size ,y)) - (the ,(store-type sym) ,sto-x) (the index-type ,stp-x) - (the ,(store-type sym) (store ,y)) (the index-type ,st-y) - ,(if ncp? 0 `(head ,x)) (head ,y))) + ,(recursive-append + (when ncp? + `(with-field-element ,sym (,sto-x ,x))) + `(,(macroexpand-1 `(t/blas-copy-func ,sym)) + (the index-type (size ,y)) + ,(if ncp? sto-x `(the ,(store-type sym) (store ,x))) (the index-type ,(if ncp? 0 st-x)) + (the ,(store-type sym) (store ,y)) (the index-type ,st-y) + ,(if ncp? 0 `(head ,x)) (head ,y))) ,y))))) - + ;; (deft/generic (t/copy! #'(lambda (a b) (strict-compare (list #'subtypep #'subtypep) a b))) (clx cly) (x y)) (deft/method t/copy! ((clx standard-tensor) (cly standard-tensor)) (x y) diff --git a/src/level-1/dot.lisp b/src/level-1/dot.lisp index 6b5825d..f3d136a 100644 --- a/src/level-1/dot.lisp +++ b/src/level-1/dot.lisp @@ -32,23 +32,23 @@ 'ddot) (deft/method t/blas-dot-func (sym complex-tensor) (&optional (conjp t)) (if conjp 'zdotc 'zdotu)) -;; +;;a (deft/generic (t/blas-dot #'subtypep) sym (x y &optional conjp num-y?)) (deft/method t/blas-dot (sym blas-numeric-tensor) (x y &optional (conjp t) (num-y? nil)) (using-gensyms (decl (x y)) (with-gensyms (sto) - `(let (,@decl - ,@(when num-y? `((,sto (t/store-allocator ,sym 1))))) - (declare (type ,sym ,x ,@(unless num-y? `(,y))) - ,@(when num-y? `((type ,(field-type sym) ,y) - (type ,(store-type sym) ,sto)))) - ,@(when num-y? `((t/store-set ,sym ,y ,sto 0))) - (,(macroexpand-1 `(t/blas-dot-func ,sym ,conjp)) - (aref (the index-store-vector (dimensions ,x)) 0) - (the ,(store-type sym) (store ,x)) (aref (the index-store-vector (strides ,x)) 0) - (the ,(store-type sym) ,(if num-y? sto `(store ,y))) ,(if num-y? 0 `(aref (the index-store-vector (strides ,y)) 0)) - (head ,x) ,(if num-y? 0 `(head ,y))))))) + `(let (,@decl) + (declare (type ,sym ,x) + (type ,(if num-y? (field-type sym) sym) ,y)) + ,(recursive-append + (when num-y? + `(with-field-element ,sym (,sto ,y))) + `(,(macroexpand-1 `(t/blas-dot-func ,sym ,conjp)) + (aref (dimensions ,x) 0) + (the ,(store-type sym) (store ,x)) (aref (strides ,x) 0) + ,(if num-y? sto `(the ,(store-type sym) (store ,y))) ,(if num-y? 0 `(aref (strides ,y) 0)) + (head ,x) ,(if num-y? 0 `(head ,y)))))))) (deft/generic (t/dot #'subtypep) sym (x y &optional conjp num-y?)) (deft/method t/dot (sym standard-tensor) (x y &optional (conjp t) (num-y? nil)) @@ -143,8 +143,8 @@ (defmethod dot ((x standard-tensor) (y t) &optional (conjugate-p t)) (let ((clx (class-name (class-of x)))) - (assert (member clx *tensor-type-leaves*) - nil 'tensor-abstract-class :tensor-class (list clx)) + (assert (member clx *tensor-type-leaves*) + nil 'tensor-abstract-class :tensor-class (list clx)) (compile-and-eval `(defmethod dot ((x ,clx) (y t) &optional (conjugate-p t)) (let ((y (t/coerce ,(field-type clx) y))) @@ -160,4 +160,3 @@ (t/dot ,clx x y t t) (t/dot ,clx x y nil t)))))) (dot x y conjugate-p))) - diff --git a/src/level-1/scal.lisp b/src/level-1/scal.lisp index 8f70505..eb89d74 100644 --- a/src/level-1/scal.lisp +++ b/src/level-1/scal.lisp @@ -45,22 +45,18 @@ (deft/method t/blas-scdi! (sym blas-numeric-tensor) (x st-x y st-y &optional (scal? t)) (let ((numx? (null st-x))) (using-gensyms (decl (x y)) - (with-gensyms (sto-x stp-x) + (with-gensyms (sto-x) `(let (,@decl) (declare (type ,sym ,@(unless numx? `(,x)) ,y) ,@(when numx? `((type ,(field-type sym) ,x)))) - (let ((,sto-x ,(if numx? `(t/store-allocator ,sym 1) `(store ,x))) - (,stp-x ,(if numx? 0 st-x))) - (declare (type ,(store-type sym) ,sto-x) - (type index-type ,stp-x)) - ,@(when numx? - `((t/store-set ,sym ,x ,sto-x 0))) - (,(macroexpand-1 `(t/blas-scdi-func ,sym ,scal?)) - (the index-type (size ,y)) - ,sto-x ,stp-x - (the ,(store-type sym) (store ,y)) (the index-type ,st-y) - ,(if numx? 0 `(head ,x)) (head ,y)) - ,y)))))) + ,(recursive-append + (when numx? `(with-field-element ,sym (,sto-x ,x))) + `(,(macroexpand-1 `(t/blas-scdi-func ,sym ,scal?)) + (the index-type (size ,y)) + ,(if numx? sto-x `(the ,(store-type sym) (store ,x))) (the index-type ,(if numx? 0 st-x)) + (the ,(store-type sym) (store ,y)) (the index-type ,st-y) + ,(if numx? 0 `(head ,x)) (head ,y))) + ,y))))) (deft/method t/scdi! (sym standard-tensor) (x y &key (scal? t) (numx? nil)) (using-gensyms (decl (x y)) commit fbb6af74f62783e94dd623de0bb6a50d3a9325c4 Author: Akshay Srinivasan <aks...@gm...> Date: Sat Dec 28 14:10:43 2013 +0530 Uncommented single float versions. diff --git a/src/classes/numeric.lisp b/src/classes/numeric.lisp index 632a85a..3e00da2 100644 --- a/src/classes/numeric.lisp +++ b/src/classes/numeric.lisp @@ -1,5 +1,8 @@ (in-package #:matlisp) +(defun subfieldp (a b) + (subtypep (field-type a) (field-type b))) + (defclass numeric-tensor (standard-tensor) ()) (deft/method t/field-type (sym numeric-tensor) () 'number) @@ -29,16 +32,18 @@ (defmethod print-element ((tensor real-numeric-tensor) element stream) (format stream "~11,5,,,,,'Eg" element)) + ;;Real tensor (defleaf real-tensor (real-numeric-tensor) ()) (deft/method t/field-type (sym real-tensor) () 'double-float) -#+nil -(progn - (defleaf sreal-tensor (real-numeric-tensor) ()) - (deft/method t/field-type (sym sreal-tensor) () - 'single-float)) +(deft/method t/complexified-type (sym real-tensor) () + 'complex-tensor) + +(defleaf sreal-tensor (real-numeric-tensor) ()) +(deft/method t/field-type (sym sreal-tensor) () + 'single-float) ;;Complex tensor (defclass complex-numeric-tensor (blas-numeric-tensor) ()) @@ -55,9 +60,9 @@ ;;Comment this block if you want to use (simple-array (complex double-float) (*)) ;;as the underlying store. This will make Lisp-implementations of gemm .. faster -;;but you'll lose the ability to use tensor-realpart~/imagpart~. +;;but you'll lose the ability to use tensor-realpart~/imagpart~. (progn - (deft/method t/store-element-type (sym complex-numeric-tensor) () + (deft/method t/store-element-type (sym complex-numeric-tensor) () (let ((cplx-type (macroexpand-1 `(t/field-type ,sym)))) (second cplx-type))) @@ -72,7 +77,7 @@ (idx-s (gensym)) (type (macroexpand-1 `(t/store-element-type ,sym)))) `(let ((,store-s ,store) - (,idx-s ,idx)) + (,idx-s ,idx)) (declare (type (simple-array ,type) ,store-s)) (complex (aref ,store-s (* 2 ,idx-s)) (aref ,store-s (1+ (* 2 ,idx-s))))))) @@ -107,8 +112,6 @@ (deft/method t/field-type (sym complex-tensor) () '(complex double-float)) -#+nil -(progn - (defleaf scomplex-tensor (complex-numeric-tensor) ()) - (deft/method t/store-element-type (sym scomplex-tensor) () - 'single-float)) +(defleaf scomplex-tensor (complex-numeric-tensor) ()) +(deft/method t/store-element-type (sym scomplex-tensor) () + '(complex single-float)) commit ecbb04d8adfe7d75a4f6d064fcb0f14a66613556 Author: Akshay Srinivasan <aks...@gm...> Date: Fri Dec 27 17:21:16 2013 +0530 Moved the foreign-structure :print-function to print-object method. diff --git a/src/ffi/foreign-vector.lisp b/src/ffi/foreign-vector.lisp index 1521986..ef8c352 100644 --- a/src/ffi/foreign-vector.lisp +++ b/src/ffi/foreign-vector.lisp @@ -1,20 +1,18 @@ (in-package #:matlisp-ffi) (defstruct (foreign-vector - (:conc-name fv-) - (:print-function (lambda (obj stream depth) - (declare (ignore depth)) - (format stream "#F(") - (let ((sz (fv-size obj))) - (dotimes (i sz) - (format stream (if (= i (- sz 1)) - "~A)" - "~A ") (fv-ref obj i))))))) + (:conc-name fv-)) (pointer (cffi:null-pointer) :type cffi:foreign-pointer) (size 0 :type fixnum) (type nil :type symbol)) +(defmethod print-object ((obj foreign-vector) stream) + (format stream "#F(") + (dotimes (i (fv-size obj)) + (format stream "~A " (fv-ref obj i))) + (format stream ")")) + (defun fv-ref (x n) (declare (type foreign-vector x) (type fixnum n)) commit c0248c645d3d100b8f2e4b6569b730cd29e7589b Author: Akshay Srinivasan <aks...@gm...> Date: Fri Dec 27 17:19:02 2013 +0530 Raised foreign-vector to be one of the matlisp-specialized-array. diff --git a/src/ffi/ffi-cffi-implementation-specific.lisp b/src/ffi/ffi-cffi-implementation-specific.lisp index d9d112f..7669c98 100644 --- a/src/ffi/ffi-cffi-implementation-specific.lisp +++ b/src/ffi/ffi-cffi-implementation-specific.lisp @@ -53,15 +53,8 @@ (defun vector-data-address (vec) " Returns the pointer address of where the actual data store of the object VEC. - -VEC - must be a either a (complex double-float), (complex single-float) -or a specialized array type in CMU Lisp. This currently means -VEC is a simple-array of one dimension of one of the following types: - - double-float - single-float - or a - system-area-pointer +VEC is a simple-array of one dimension of type 'matlisp-specialized-array. +VEC can also be a foreign-vector. Returns 1 - system area pointer to the actual data @@ -75,9 +68,13 @@ Returns (with-optimization (:speed 3 :safety 0 :space 0) ;;vec is either a simple-array or a system-area-pointer itself. (declare (type matlisp-specialized-array vec)) - (if (typep vec '(simple-array * (*))) - (vector-sap-interpreter-specific vec) - vec))) + (etypecase vec + ((simple-array * (*)) + (vector-sap-interpreter-specific vec)) + (cffi:foreign-pointer + vec) + (foreign-vector + (fv-pointer vec))))) #+(or sbcl cmu ccl) (defmacro with-vector-data-addresses (vlist &body body) diff --git a/src/ffi/ffi-cffi.lisp b/src/ffi/ffi-cffi.lisp index 5175304..10c7649 100644 --- a/src/ffi/ffi-cffi.lisp +++ b/src/ffi/ffi-cffi.lisp @@ -143,6 +143,9 @@ ;; Supporting multidimensional arrays is a pain. ;; Only support types that we currently use. +(definline allowed-fv-type? (x) + (member (fv-type x) '(:double :float :int :uint :int64 :uint64))) + (deftype matlisp-specialized-array () `(or (simple-array double-float (*)) (simple-array single-float (*)) @@ -157,7 +160,8 @@ (simple-array (unsigned-byte 64) *) (simple-array (unsigned-byte 32) *) ;; - cffi:foreign-pointer)) + cffi:foreign-pointer + (and foreign-vector (satisfies allowed-fv-type?)))) ;; Very inefficient - compilation wise, not runtime wise- ;; (but portable!) way of supporting both SAPs and simple-arrays. @@ -177,16 +181,18 @@ Example: >> " (labels ((with-pointer-or-vector-data-address (vlist body) - (let ((inc-body (ecase (length vlist) - (2 nil) - (4 `((incf-sap ,(nth 2 vlist) ,(nth 0 vlist) ,(nth 3 vlist))))))) - `(if (cffi:pointerp ,(cadr vlist)) - (let (,(car vlist) ,(cadr vlist)) - ,@inc-body - ,@body) - (cffi-sys:with-pointer-to-vector-data (,(car vlist) ,(cadr vlist)) - ,@inc-body - ,@body)))) + (destructuring-bind (addr vec &key inc-type inc) vlist + (let ((inc-body (when inc-type + `((incf-sap ,addr ,inc-type ,@(when inc `(,inc))))))) + `(etypecase vec + ((simple-array * (*)) + (cffi-sys:with-pointer-to-vector-data (,addr ,vec) + ,@inc-body + ,@body)) + ((or foreign-vector cffi:foreign-pointer) + (let ((,addr (if (typep vec foreign-vector) (fv-pointer ,vec) ,vec))) + ,@inc-body + ,@body)))))) (frob (v body) (if (null v) body commit 32bce0a5847fc2b5ee46698b2e6e0a3a63466d4d Author: Akshay Srinivasan <aks...@gm...> Date: Fri Dec 27 17:15:57 2013 +0530 Changed "subfieldp" to be the template sorting function; now lapack methods. diff --git a/src/lapack/chol.lisp b/src/lapack/chol.lisp index fabbbd9..9d5d265 100644 --- a/src/lapack/chol.lisp +++ b/src/lapack/chol.lisp @@ -27,7 +27,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package #:matlisp) -(deft/generic (t/lapack-potrf-func #'subtypep) sym ()) +(deft/generic (t/lapack-potrf-func #'subfieldp) sym ()) (deft/method t/lapack-potrf-func (sym real-tensor) () 'dpotrf) (deft/method t/lapack-potrf-func (sym complex-tensor) () @@ -92,7 +92,7 @@ (potrf! A uplo))) ;; -(deft/generic (t/lapack-potrs-func #'subtypep) sym ()) +(deft/generic (t/lapack-potrs-func #'subfieldp) sym ()) (deft/method t/lapack-potrs-func (sym real-tensor) () 'dpotrs) (deft/method t/lapack-potrs-func (sym complex-tensor) () diff --git a/src/lapack/eig.lisp b/src/lapack/eig.lisp index ed67faf..98b0fcc 100644 --- a/src/lapack/eig.lisp +++ b/src/lapack/eig.lisp @@ -1,6 +1,6 @@ (in-package #:matlisp) -(deft/generic (t/lapack-geev-func #'subtypep) sym ()) +(deft/generic (t/lapack-geev-func #'subfieldp) sym ()) (deft/method t/lapack-geev-func (sym real-tensor) () 'dgeev) @@ -12,7 +12,7 @@ ;; (deft/generic (t/geev-output-fix #'subtypep) sym (wr wi)) (deft/method t/geev-output-fix (sym real-numeric-tensor) (wr wi) - (let ((csym (or (complexified-type sym) (error "No corresponding complex-tensor defined for type ~a." sym)))) + (let ((csym (complexified-type sym))) (using-gensyms (decl (wr wi)) (with-gensyms (ret i) `(let* (,@decl diff --git a/src/lapack/geqr.lisp b/src/lapack/geqr.lisp index 2c52eba..7d9695f 100644 --- a/src/lapack/geqr.lisp +++ b/src/lapack/geqr.lisp @@ -1,6 +1,6 @@ (in-package #:matlisp) -(deft/generic (t/lapack-geqrf-func #'subtypep) sym ()) +(deft/generic (t/lapack-geqrf-func #'subfieldp) sym ()) (deft/method t/lapack-geqrf-func (sym real-tensor) () 'matlisp-lapack:dgeqrf) (deft/method t/lapack-geqrf-func (sym complex-tensor) () diff --git a/src/lapack/least-squares.lisp b/src/lapack/least-squares.lisp index ef4f911..6c50794 100644 --- a/src/lapack/least-squares.lisp +++ b/src/lapack/least-squares.lisp @@ -1,6 +1,6 @@ (in-package :matlisp) -(deft/generic (t/lapack-gelsy-func #'subtypep) sym ()) +(deft/generic (t/lapack-gelsy-func #'subfieldp) sym ()) (deft/method t/lapack-gelsy-func (sym real-tensor) () 'dgelsy) diff --git a/src/lapack/lu.lisp b/src/lapack/lu.lisp index 1c5e7f7..1325c6b 100644 --- a/src/lapack/lu.lisp +++ b/src/lapack/lu.lisp @@ -27,7 +27,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package #:matlisp) -(deft/generic (t/lapack-getrf-func #'subtypep) sym ()) +(deft/generic (t/lapack-getrf-func #'subfieldp) sym ()) (deft/method t/lapack-getrf-func (sym real-tensor) () 'dgetrf) (deft/method t/lapack-getrf-func (sym complex-tensor) () @@ -142,7 +142,7 @@ ;; (let* ((min (lvec-min (dimensions lu))) ;; ( ;; -(deft/generic (t/lapack-getrs-func #'subtypep) sym ()) +(deft/generic (t/lapack-getrs-func #'subfieldp) sym ()) (deft/method t/lapack-getrs-func (sym real-tensor) () 'dgetrs) (deft/method t/lapack-getrs-func (sym complex-tensor) () commit 24fca164d6b861365bdc977de64a29e6107da555 Author: Akshay Srinivasan <aks...@gm...> Date: Fri Dec 27 17:12:50 2013 +0530 Changed "subfieldp" to be the method sorting function. diff --git a/src/level-1/axpy.lisp b/src/level-1/axpy.lisp index 78cf827..73305ca 100644 --- a/src/level-1/axpy.lisp +++ b/src/level-1/axpy.lisp @@ -27,7 +27,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package #:matlisp) -(deft/generic (t/blas-axpy-func #'subtypep) sym ()) +(deft/generic (t/blas-axpy-func #'subfieldp) sym ()) (deft/method t/blas-axpy-func (sym real-tensor) () 'daxpy) (deft/method t/blas-axpy-func (sym complex-tensor) () diff --git a/src/level-1/copy.lisp b/src/level-1/copy.lisp index c90bbff..0e4207b 100644 --- a/src/level-1/copy.lisp +++ b/src/level-1/copy.lisp @@ -27,7 +27,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package #:matlisp) -(deft/generic (t/blas-copy-func #'subtypep) sym ()) +(deft/generic (t/blas-copy-func #'subfieldp) sym ()) (deft/method t/blas-copy-func (sym real-tensor) () 'dcopy) (deft/method t/blas-copy-func (sym complex-tensor) () @@ -117,110 +117,6 @@ (,of-y (strides ,y) (head ,y))) :do (t/store-set ,cly ,cx ,sto-y ,of-y))) ,y)))) -;; -;;This macro is used for interfacing with lapack -;;Only to be used with matrices! - -#| -(deft/generic (t/copy-triangle! #'subtypep) sym (a b &optional upper?)) -(deft/method t/copy-triangle! (sym standard-tensor) (a b &optional (upper? t)) - (using-gensyms (decl (diag a b)) - (with-gensyms (sto-a sto-b strd-a strd-b dof-a dof-b of-a of-b) - `(let* (,@decl - (,sto-a (store ,a)) - (,strd-a (strides ,a)) - (,sto-b (store ,b)) - (,strd-b (strides ,b))) - (declare (type ,sym ,a ,b) - (type ,(store-type sym) ,sto-a ,sto-b) - (type index-store-vector ,strd-a ,strd-b)) - (ecase ,diag - (t - (with-marking - (very-quickly - (:mark* ((ndiags (min (nrows ,a) (ncols ,a)))) - (loop :for i :from 0 :below ndiags - :for ,dof-a :of-type index-type := (head ,a) :then (+ ,dof-a (:mark (lvec-foldr #'+ ,strd-a) :type index-type)) - :for ,dof-b :of-type index-type := (head ,b) :then (+ ,dof-b (:mark (lvec-foldr #'+ ,strd-b) :type index-type)) - :do (loop :for j :from 0 :below ,(if upper? `(1+ i) `(- ndiags i)) - :for ,of-a :of-type index-type := ,dof-a :then (,(if upper? '- '+) ,of-a (:mark (aref ,strd-a 0))) - :for ,of-b :of-type index-type := ,dof-b :then (,(if upper? '- '+) ,of-b (:mark (aref ,strd-b 0))) - :do (t/store-set ,sym (t/store-ref ,sym ,sto-a ,of-a) ,sto-b ,of-b))))))) - - ,b)))) -;; -(deft/generic (t/copy-triangle! #'subtypep) sym (a b &optional upper?)) -(deft/method t/copy-triangle! (sym standard-tensor) (a b &optional (upper? t)) - (using-gensyms (decl (a b)) - (with-gensyms (sto-a sto-b strd-a strd-b dof-a dof-b of-a of-b) - `(let* (,@decl - (,sto-a (store ,a)) - (,strd-a (strides ,a)) - (,sto-b (store ,b)) - (,strd-b (strides ,b))) - (declare (type ,sym ,a ,b) - (type ,(store-type sym) ,sto-a ,sto-b) - (type index-store-vector ,strd-a ,strd-b)) - (with-marking - (very-quickly - (:mark* ((ndiags (min (nrows ,a) (ncols ,a)))) - (loop :for i :from 0 :below ndiags - :for ,dof-a :of-type index-type := (head ,a) :then (+ ,dof-a (:mark (lvec-foldr #'+ ,strd-a) :type index-type)) - :for ,dof-b :of-type index-type := (head ,b) :then (+ ,dof-b (:mark (lvec-foldr #'+ ,strd-b) :type index-type)) - :do (loop :for j :from 0 :below ,(if upper? `(1+ i) `(- ndiags i)) - :for ,of-a :of-type index-type := ,dof-a :then (,(if upper? '- '+) ,of-a (:mark (aref ,strd-a 0))) - :for ,of-b :of-type index-type := ,dof-b :then (,(if upper? '- '+) ,of-b (:mark (aref ,strd-b 0))) - :do (t/store-set ,sym (t/store-ref ,sym ,sto-a ,of-a) ,sto-b ,of-b)))))) - ,b)))) -;; -(deft/generic (t/copy-diagonal! #'subtypep) sym (a b &optional num?)) -(deft/method t/copy-diagonal! (sym standard-tensor) (a b &optional (num? nil)) - (using-gensyms (decl (a b)) - (with-gensyms (sto-a sto-b of-a of-b) - `(let* (,@decl - ,@(unless num? `((,sto-a (store ,a)))) - (,sto-b (store ,b))) - (declare (type ,sym ,@(unless num? `(,a)) ,b) - (type ,(store-type sym) ,@(unless num? `(,sto-a)) ,sto-b) - ,@(when num? `((type ,(field-type sym) ,a)))) - (with-marking - (very-quickly - (:mark* ((ndiags (lvec-min (dimensions ,b)))) - (loop :for i :from 0 :below ndiags - ,@(unless num? `(:for ,of-a :of-type index-type := (head ,a) :then (+ ,of-a (:mark (lvec-foldr #'+ (strides ,a)) :type index-type)))) - :for ,of-b :of-type index-type := (head ,b) :then (+ ,of-b (:mark (lvec-foldr #'+ (strides ,b)) :type index-type)) - :do (t/store-set ,sym ,@(if num? `(,a) `((t/store-ref ,sym ,sto-a ,of-a))) ,sto-b ,of-b))))) - ,b)))) - -;; -(defgeneric copy-triangle! (x y &key upper? diag?) - (:method :before ((x standard-tensor) (y standard-tensor) &key upper? diag?) - (assert (and (tensor-matrixp x) (tensor-matrixp y) - (= (lvec-min (dimensions x)) (lvec-min (dimensions y)))) - nil 'tensor-dimension-mismatch))) - - -(defmethod copy-triangle! ((x standard-tensor) (y standard-tensor) &key (upper? t) (diag? t)) - (let ((clx (class-name (class-of x))) - (cly (class-name (class-of y)))) - (assert (and (member clx *tensor-type-leaves*) - (member cly *tensor-type-leaves*) - (eql clx cly)) - nil 'tensor-abstract-class :tensor-class (list clx cly)) - (compile-and-eval - (let ((expr `()))) - `(defmethod copy-triangle! ((x ,clx) (y ,cly) &key (upper? t) (diag? t)) - (ecase diag? - (t ;;copy diagonal - (if upper? (t/copy-triangle! ,clx x y t) (t/copy-triangle! ,clx x y nil))) - (number - (let ((num (t/coerce ,(t/field-type clx) diag?))) - (if upper? (t/copy-triangle! ,clx x y t) (t/copy-triangle! ,clx x y nil)) - (t/copy-diagonal! ,clx num y t))) - (nil - (let ((num - -|# ;; (defmethod copy! :before ((x standard-tensor) (y standard-tensor)) @@ -266,6 +162,18 @@ (copy! x y))) ;;Generic function defined in src;base;generic-copy.lisp -(defmethod copy ((tensor standard-tensor)) - (let* ((ret (zeros (the index-store-vector (dimensions tensor)) (class-name (class-of tensor))))) - (copy! tensor ret))) +(defmethod copy-generic ((tensor standard-tensor) type) + (cond + ((eql type 'array) + (let ((ret (make-array (lvec->list (dimensions tensor))))) + (copy! tensor ret))) + ((member type '(list cons)) + (labels ((mtree (arr idx) + (let ((n (length idx))) + (if (= n (rank arr)) (apply #'ref arr idx) + (loop :for i :from 0 :below (aref (dimensions arr) n) + :collect (mtree arr (append idx (list i)))))))) + (mtree tensor nil))) + ((or (not type) (subtypep type 'standard-tensor)) + (let ((ret (zeros (dimensions tensor) (or type (class-of tensor))))) + (copy! tensor ret))))) diff --git a/src/level-1/dot.lisp b/src/level-1/dot.lisp index 3a81f7e..6b5825d 100644 --- a/src/level-1/dot.lisp +++ b/src/level-1/dot.lisp @@ -27,7 +27,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package #:matlisp) -(deft/generic (t/blas-dot-func #'subtypep) sym (&optional conjp)) +(deft/generic (t/blas-dot-func #'subfieldp) sym (&optional conjp)) (deft/method t/blas-dot-func (sym real-tensor) (&optional conjp) 'ddot) (deft/method t/blas-dot-func (sym complex-tensor) (&optional (conjp t)) diff --git a/src/level-1/scal.lisp b/src/level-1/scal.lisp index cedea4d..8f70505 100644 --- a/src/level-1/scal.lisp +++ b/src/level-1/scal.lisp @@ -27,7 +27,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package #:matlisp) -(deft/generic (t/blas-scdi-func #'subtypep) sym (&optional scal?)) +(deft/generic (t/blas-scdi-func #'subfieldp) sym (&optional scal?)) (deft/method t/blas-scdi-func (sym real-tensor) (&optional (scal? t)) (if scal? @@ -39,7 +39,7 @@ 'zescal 'zediv)) ;; -(deft/generic (t/blas-scdi! #'subtypep) sym (x st-x y st-y &optional scal?)) +(deft/generic (t/blas-scdi! #'subfieldp) sym (x st-x y st-y &optional scal?)) (deft/generic (t/scdi! #'subtypep) sym (x y &key scal? numx?)) (deft/method t/blas-scdi! (sym blas-numeric-tensor) (x st-x y st-y &optional (scal? t)) diff --git a/src/level-1/swap.lisp b/src/level-1/swap.lisp index 2d0245b..880a197 100644 --- a/src/level-1/swap.lisp +++ b/src/level-1/swap.lisp @@ -27,7 +27,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package #:matlisp) -(deft/generic (t/blas-swap-func #'subtypep) sym ()) +(deft/generic (t/blas-swap-func #'subfieldp) sym ()) (deft/method t/blas-swap-func (sym real-tensor) () 'dswap) (deft/method t/blas-swap-func (sym complex-tensor) () diff --git a/src/level-2/gemv.lisp b/src/level-2/gemv.lisp index 75ba8a2..c305481 100644 --- a/src/level-2/gemv.lisp +++ b/src/level-2/gemv.lisp @@ -1,6 +1,6 @@ (in-package #:matlisp) -(deft/generic (t/blas-gemv-func #'subtypep) sym ()) +(deft/generic (t/blas-gemv-func #'subfieldp) sym ()) (deft/method t/blas-gemv-func (sym real-tensor) () 'dgemv) (deft/method t/blas-gemv-func (sym complex-tensor) () diff --git a/src/level-3/gemm.lisp b/src/level-3/gemm.lisp index 7c824c0..aadb836 100644 --- a/src/level-3/gemm.lisp +++ b/src/level-3/gemm.lisp @@ -1,6 +1,6 @@ (in-package #:matlisp) -(deft/generic (t/blas-gemm-func #'subtypep) sym ()) +(deft/generic (t/blas-gemm-func #'subfieldp) sym ()) (deft/method t/blas-gemm-func (sym real-tensor) () 'dgemm) (deft/method t/blas-gemm-func (sym complex-tensor) () commit 6dacaaaa8356ad476ac631eb95b93829a5f1e3f1 Author: Akshay Srinivasan <aks...@gm...> Date: Fri Dec 27 17:08:57 2013 +0530 Added optional type for "copy" generic function. diff --git a/src/base/generic-copy.lisp b/src/base/generic-copy.lisp index aa30346..2f0dc7f 100644 --- a/src/base/generic-copy.lisp +++ b/src/base/generic-copy.lisp @@ -12,14 +12,14 @@ Copies the contents of X into Y. Returns Y. ") (:method :before ((x array) (y array)) - (assert (list-eq (array-dimensions x) (array-dimensions y)) + (assert (list-eq (array-dimensions x) (array-dimensions y)) nil 'dimension-mismatch))) (defmethod copy! ((from cons) (to cons)) - (let-rec cdr-writer ((flst from) (tlst to)) - (unless (or (null flst) (null tlst)) - (setf (car tlst) (car flst)) - (cdr-writer (cdr flst) (cdr tlst)))) + (do ((flst from (cdr flst)) + (tlst to (cdr tlst))) + ((or (null flst) (null tlst))) + (setf (car tlst) (car flst))) to) (defmethod copy! ((from t) (to cons)) @@ -57,10 +57,10 @@ `(defmethod copy! ((x array) (y ,clname)) (let-typed ((sto-y (store y) :type (simple-array ,(store-element-type clname))) (lst (make-list (array-rank x)) :type cons)) - (mod-dotimes (idx (dimensions y)) - :with (linear-sums - (of-y (strides y) (head y))) - :do (t/store-set ,clname (t/coerce ,(field-type clname) (apply #'aref x (lvec->list! idx lst))) sto-y of-y))) + (mod-dotimes (idx (dimensions y)) + :with (linear-sums + (of-y (strides y) (head y))) + :do (t/store-set ,clname (t/coerce ,(field-type clname) (apply #'aref x (lvec->list! idx lst))) sto-y of-y))) y)) (copy! x y))) @@ -71,10 +71,10 @@ `(defmethod copy! ((x ,clname) (y array)) (let-typed ((sto-x (store x) :type (simple-array ,(store-element-type clname))) (lst (make-list (array-rank y)) :type cons)) - (mod-dotimes (idx (dimensions x)) - :with (linear-sums - (of-x (strides x) (head x))) - :do (setf (apply #'aref y (lvec->list! idx lst)) (t/store-ref ,clname sto-x of-x)))) + (mod-dotimes (idx (dimensions x)) + :with (linear-sums + (of-x (strides x) (head x))) + :do (setf (apply #'aref y (lvec->list! idx lst)) (t/store-ref ,clname sto-x of-x)))) y)) (copy! x y))) @@ -83,23 +83,47 @@ (let ((arr (make-array (list-dimensions x) :initial-contents x))) (copy! arr y))) ;; -(defgeneric copy (object) - (:documentation +(defgeneric copy-generic (object type) + (:documentation " Syntax ====== - (COPY x) - + (COPY-GENERIC x type) + Purpose ======= - Return a copy of X")) + Return a copy of X coerced to TYPE")) + +(definline copy (obj &optional type) + (copy-generic obj type)) -(defmethod copy ((num number)) - num) +(defmethod copy-generic ((num number) type) + (if type (coerce num type) num)) -(defmethod copy ((lst cons)) - (copy-list lst)) +(defmethod copy-generic ((lst cons) type) + (cond + ((member type '(list cons nil)) (copy-tree lst)) + ((eql type 'vector) (make-array (length lst) :initial-contents lst)) + ((eql type 'array) + (make-array (list-dimensions lst) :initial-contents lst)) + ((subtypep type 'standard-tensor) + (let ((ret (zeros (list-dimensions lst) type))) + (copy! lst ret))) + (t (error "don't know how to copy a list to type ~a" type)))) -(defmethod copy ((arr array)) - (let ((ret (make-array (array-dimensions arr) :element-type (array-element-type arr)))) - (copy! arr ret))) +(defmethod copy-generic ((arr array) type) + (cond + ((member type '(array nil)) + (let ((ret (make-array (array-dimensions arr) :element-type (array-element-type arr)))) + (copy! arr ret))) + ((member type '(list cons)) + (labels ((mtree (arr idx) + (let ((n (length idx))) + (if (= n (array-rank arr)) (apply #'aref arr idx) + (loop :for i :from 0 :below (array-dimension arr n) + :collect (mtree arr (append idx (list i)))))))) + (mtree arr nil))) + ((subtypep type 'standard-tensor) + (let ((ret (zeros (array-dimensions arr) type))) + (copy! arr ret))) + (t (error "don't know how to copy a list to type ~a" type)))) commit 03fc1d7dafa1157eea84f9df3f0a24f1b4b240cd Author: Akshay Srinivasan <aks...@gm...> Date: Fri Dec 27 17:06:35 2013 +0530 Removed coerce-tensor; the new copy method takes its place. diff --git a/src/base/standard-tensor.lisp b/src/base/standard-tensor.lisp index b69c67a..3597250 100644 --- a/src/base/standard-tensor.lisp +++ b/src/base/standard-tensor.lisp @@ -93,11 +93,6 @@ tensor, for example #.(make-tensors ...)" (make-load-form-saving-slots tensor :environment env)) -;; -(definline coerce-tensor (x cly) - (declare (type standard-tensor x)) - (copy! x (zeros (the index-store-vector (dimensions x)) cly))) - ;;These should ideally be memoised (or not) (definline rank (tensor) (declare (type standard-tensor tensor)) commit 1d27fd93c94b99ff3f6fda26106e50c4d4cf1b01 Author: Akshay Srinivasan <aks...@gm...> Date: Fri Dec 27 16:27:05 2013 +0530 Changed templates to be less verbose. diff --git a/src/base/template.lisp b/src/base/template.lisp index 65a296c..b7fe327 100644 --- a/src/base/template.lisp +++ b/src/base/template.lisp @@ -3,42 +3,28 @@ ;;Field templates (deft/generic (t/f+ #'subtypep) ty (&rest nums)) (deft/method t/f+ (ty number) (&rest nums) - (let* ((decl (zipsym nums)) - (args (mapcar #'car decl))) - `(let (,@decl) - (declare (type ,ty ,@args)) - (cl:+ ,@args)))) + `(cl:+ ,@(mapcar #'(lambda (x) `(the ,ty ,x)) nums))) (deft/generic (t/f- #'subtypep) ty (&rest nums)) (deft/method t/f- (ty number) (&rest nums) - (let* ((decl (zipsym nums)) - (args (mapcar #'car decl))) - `(let (,@decl) - (declare (type ,ty ,@args)) - (cl:- ,@args)))) + `(cl:- ,@(mapcar #'(lambda (x) `(the ,ty ,x)) nums))) (deft/generic (t/f* #'subtypep) ty (&rest nums)) (deft/method t/f* (ty number) (&rest nums) - (let* ((decl (zipsym nums)) - (args (mapcar #'car decl))) - `(let (,@decl) - (declare (type ,ty ,@args)) - (cl:* ,@args)))) + `(cl:* ,@(mapcar #'(lambda (x) `(the ,ty ,x)) nums))) (deft/generic (t/f/ #'subtypep) ty (&rest nums)) (deft/method t/f/ (ty number) (&rest nums) - (let* ((decl (zipsym nums)) - (args (mapcar #'car decl))) - `(let (,@decl) - (declare (type ,ty ,@args)) - (cl:/ ,@args)))) + `(cl:/ ,@(mapcar #'(lambda (x) `(the ,ty ,x)) nums))) + +(deft/generic (t/f= #'subtypep) ty (&rest nums)) +(deft/method t/f= (ty number) (&rest nums) + `(cl:= ,@(mapcar #'(lambda (x) `(the ,ty ,x)) nums))) ;; (deft/generic (t/fc #'subtypep) ty (num)) (deft/method t/fc (ty number) (num) - (with-gensyms (num-sym) - `(let ((,num-sym ,num)) - (cl:conjugate ,num-sym)))) + `(cl:conjugate ,num)) (deft/method t/fc (ty real) (num) num) @@ -70,21 +56,11 @@ (deft/generic (t/fimagpart #'subtypep) ty (num)) (deft/method t/fimagpart (ty number) (num) - (with-gensyms (num-sym) - `(let ((,num-sym ,num)) - (cl:imagpart ,num-sym)))) + `(cl:imagpart ,num)) (deft/method t/fimagpart (ty real) (num) `(t/fid+ ,ty)) ;; -(deft/generic (t/f= #'subtypep) ty (&rest nums)) -(deft/method t/f= (ty number) (&rest nums) - (let* ((decl (zipsym nums)) - (args (mapcar #'car decl))) - `(let (,@decl) - (declare (type ,ty ,@args)) - (cl:= ,@args)))) - (deft/generic (t/fid+ #'subtypep) ty ()) (deft/method t/fid+ (ty number) () (coerce 0 ty)) @@ -107,16 +83,11 @@ (defun field-type (clname) (macroexpand-1 `(t/field-type ,clname))) +;;This is useful for Eigenvalue decompositions +(deft/generic (t/complexified-type #'subtypep) sym ()) -;;Hack? Yes. -(defun complexified-type (ten) - (let ((ty (macroexpand-1 `(t/field-type ,ten)))) - (if (subtypep ty 'complex) ten - (let* ((cty `(complex ,ty)) - (table-entry (or (gethash 't/field-type matlisp-template::*template-table*) (ERROR "Undefined template : ~a~%" 'T/FIELD-TYPE)))) - (car (find cty (mapcar #'(lambda (x) (list (cadr x) (funcall (car x) (cadr x)))) - (getf table-entry :methods)) - :key #'second :test #'list-eq)))))) +(defun complexified-type (type) + (macroexpand-1 `(t/complexified-type ,type))) ;;Beware of infinite loops here. (deft/generic (t/store-element-type #'subtypep) sym ()) @@ -150,26 +121,11 @@ (deft/generic (t/store-ref #'subtypep) sym (store idx)) (deft/method t/store-ref (sym standard-tensor) (store idx) - (let ((store-s (gensym)) - (idx-s (gensym))) - `(let ((,store-s ,store) - (,idx-s ,idx)) - (declare (type ,(store-type sym) ,store-s)) - (aref ,store-s ,idx-s)))) + `(aref (the ,(store-type sym) ,store) (the index-type ,idx))) (deft/generic (t/store-set #'subtypep) sym (value store idx)) (deft/method t/store-set (sym standard-tensor) (value store idx) - (let ((store-s (gensym)) - (idx-s (gensym)) - (value-s (gensym)) - (type (macroexpand-1 `(t/field-type ,sym)))) - `(let ((,store-s ,store) - (,idx-s ,idx) - (,value-s ,value)) - (declare (type ,(store-type sym) ,store-s) - (type ,type ,value-s)) - (setf (aref ,store-s ,idx-s) ,value-s) - nil))) + `(setf (aref (the ,(store-type sym) ,store) (the index-type ,idx)) (the ,(field-type sym) ,value))) (deft/generic (t/coerce #'subtypep) ty (val)) (deft/method t/coerce (ty number) (val) @@ -195,7 +151,7 @@ ;;This one is hard to get one's brain around. (deft/generic (t/strict-coerce #'(lambda (a b) (strict-compare (list #'subtypep #'(lambda (x y) (subtypep y x))) a b)) - #'(lambda (a b) (dict-compare (list #'subtypep #'subtypep) b a))) + #'(lambda (a b) (dict-compare (list #'subtypep #'subtypep) b a))) (from to) (val)) ;;Anything can be coerced into type "t" commit 23f3205a3cad2be9a270bd0dc4acb57d42d8dbb2 Author: Akshay Srinivasan <aks...@gm...> Date: Thu Dec 26 18:58:30 2013 +0530 Added compiler for store-size. diff --git a/src/base/standard-tensor.lisp b/src/base/standard-tensor.lisp index cc1dab1..b69c67a 100644 --- a/src/base/standard-tensor.lisp +++ b/src/base/standard-tensor.lisp @@ -124,7 +124,12 @@ Returns the number of elements the store of the tensor can hold (which is not necessarily equal to its vector length).") (:method ((tensor standard-tensor)) - (length (store tensor)))) + (let ((clname (class-name (class-of tensor)))) + (assert (member clname *tensor-type-leaves*) nil 'tensor-abstract-class :tensor-class clname) + (compile-and-eval + `(defmethod store-size ((tensor ,clname)) + (t/store-size ,clname (store tensor)))) + (store-size tensor)))) (defgeneric print-element (tensor element stream) commit 376d74de0a77839136869bcc27c5f877cb4a3bc8 Author: Akshay Srinivasan <aks...@gm...> Date: Thu Dec 5 00:28:54 2013 -0800 Added an equality test in compute-t/dispatch. diff --git a/src/utilities/functions.lisp b/src/utilities/functions.lisp index e26251a..c131fa2 100644 --- a/src/utilities/functions.lisp +++ b/src/utilities/functions.lisp @@ -35,8 +35,8 @@ lst)) (defun list-eq (a b &optional (test #'eq)) - (if (or (atom a) (atom b)) (eq a b) - (and (funcall test (car a) (car b)) (list-eq (cdr a) (cdr b) test)))) + (if (or (atom a) (atom b)) (funcall test a b) + (and (list-eq (car a) (car b)) (list-eq (cdr a) (cdr b) test)))) (defun remmeth (func spls &optional quals) (let ((meth (find-method func quals (mapcar #'(lambda (x) (if (consp x) x (find-class x))) spls) nil))) diff --git a/src/utilities/template.lisp b/src/utilities/template.lisp index 99f029c..f11fe68 100644 --- a/src/utilities/template.lisp +++ b/src/utilities/template.lisp @@ -36,10 +36,10 @@ (error "undefined template : ~a~%" name))) (pred (getf data :predicate)) (meth (getf data :methods))) - (or (car (loop :for spl :in meth - :do (when (funcall pred args (second spl)) - (return spl)))) - (error "could not find a \"~a\" template for : ~a~%" name args))))) + (car (or + (find args meth :test #'list-eq :key #'second) + (find args meth :test pred :key #'second) + (error "could not find a \"~a\" template for : ~a~%" name args)))))) ;; (defun single-argp (name) commit 953ce0f60f25157a4fc5b5d31403433aeb47e894 Author: Akshay Srinivasan <aks...@gm...> Date: Wed Dec 4 23:20:23 2013 -0800 Renamed sub-tensor~ to subtensor~. diff --git a/src/base/permutation.lisp b/src/base/permutation.lisp index 02135a5..84f3517 100644 --- a/src/base/permutation.lisp +++ b/src/base/permutation.lisp @@ -198,7 +198,7 @@ (defmethod permute! ((A standard-tensor) (perm permutation-pivot-flip) &optional (arg 0)) (multiple-value-bind (t1 t2) (let ((slst (make-list (rank A) :initial-element '(* * *)))) (rplaca (nthcdr arg slst) (list 0 '* 1)) - (values (sub-tensor~ A slst nil) (sub-tensor~ A slst nil))) + (values (subtensor~ A slst nil) (subtensor~ A slst nil))) (let-typed ((argstd (aref (strides A) arg) :type index-type) (hd-sl (head t2) :type index-type) (idiv (store perm) :type pindex-store-vector)) diff --git a/src/base/standard-tensor.lisp b/src/base/standard-tensor.lisp index cccd99b..cc1dab1 100644 --- a/src/base/standard-tensor.lisp +++ b/src/base/standard-tensor.lisp @@ -107,6 +107,11 @@ (declare (type standard-tensor tensor)) (lvec-foldr #'* (the index-store-vector (dimensions tensor)))) +(definline dims (tensor) + (declare (type standard-tensor tensor)) + (memoizing (tensor dims) + (lvec->list (the index-store-vector (dimensions tensor))))) + ;; (defgeneric store-size (tensor) (:documentation " @@ -361,11 +366,11 @@ :finally (return t)))) ;; -(defun sub-tensor~ (tensor subscripts &optional (preserve-rank nil)) +(defun subtensor~ (tensor subscripts &optional (preserve-rank nil)) " Syntax ====== - (SUB-TENSOR~ TENSOR SUBSCRIPTS) + (SUBTENSOR~ TENSOR SUBSCRIPTS) Purpose ======= @@ -379,13 +384,13 @@ X ;; Get (:, 0, 0) - > (sub-tensor~ X '((* * *) (0 * 1) (0 * 1))) + > (subtensor~ X '((* * *) (0 * 1) (0 * 1))) ;; Get (:, 2:5, :) - > (sub-tensor~ X '((* * *) (2 * 5))) + > (subtensor~ X '((* * *) (2 * 5))) ;; Get (:, :, 0:2:10) (0:10:2 = [i : 0 <= i < 10, i % 2 = 0]) - > (sub-tensor~ X '((* * *) (* * *) (0 2 10))) + > (subtensor~ X '((* * *) (* * *) (0 2 10))) Commentary ========== @@ -449,7 +454,7 @@ (definline slice~ (x axis &optional (idx 0)) (let ((slst (make-list (rank x) :initial-element '(* * *)))) (rplaca (nthcdr axis slst) (list idx '* (1+ idx))) - (sub-tensor~ x slst nil))) + (subtensor~ x slst nil))) (definline row-slice~ (x idx) (slice~ x 0 idx)) diff --git a/src/lapack/least-squares.lisp b/src/lapack/least-squares.lisp index 7816998..ef4f911 100644 --- a/src/lapack/least-squares.lisp +++ b/src/lapack/least-squares.lisp @@ -138,14 +138,14 @@ (let* ((rank-A 0) (mn (max (nrows A) (ncols A))) (X (let ((*default-stride-ordering* :col-major)) (zeros (list mn (ncols B)) ',cla)))) - (copy! B (sub-tensor~ X `((0 * ,(nrows A)) (* * *)) t)) + (copy! B (subtensor~ X `((0 * ,(nrows A)) (* * *)) t)) (multiple-value-bind (sto-a sto-b jpvt rank work-out info) (t/lapack-gelsy! ,cla A (or (blas-matrix-compatiblep A #\N) 0) X (or (blas-matrix-compatiblep X #\N) 0) rcond work) ;;TODO: Implement inverse permutation-action, and return jpvt. (declare (ignore sto-a sto-b work-out jpvt)) (setf rank-a rank) (unless (= info 0) (error "gelsy returned ~a." info))) - (values (copy (sub-tensor~ X `((0 * ,(ncols A)) (* * *)) t)) rank-a))))) + (values (copy (subtensor~ X `((0 * ,(ncols A)) (* * *)) t)) rank-a))))) (gelsy A B rcond)) (t (error "Don't know how to apply getrs! to classes ~a." (list cla clb)))))) diff --git a/src/level-1/sum.lisp b/src/level-1/sum.lisp index dc6dada..73f4255 100644 --- a/src/level-1/sum.lisp +++ b/src/level-1/sum.lisp @@ -11,7 +11,7 @@ (type index-type ,axis)) (let ((,view (let ((slst (make-list (rank ,x) :initial-element '(* * *)))) (rplaca (nthcdr ,axis slst) (list 0 '* 1)) - (sub-tensor~ ,x slst nil))) + (subtensor~ ,x slst nil))) (,argstd (aref (the index-store-vector (strides ,x)) ,axis))) (declare (type ,sym ,view) (type index-type ,argstd)) @@ -61,5 +61,3 @@ (t/sum ,clx x nil)))) (sum! x y axis))) - - diff --git a/src/reader/loadsave.lisp b/src/reader/loadsave.lisp index 5d51b9c..b35f5cb 100644 --- a/src/reader/loadsave.lisp +++ b/src/reader/loadsave.lisp @@ -41,7 +41,15 @@ returning two values: the string and the number of bytes read." (split-seq #'(lambda (x) (or (char= x #\Newline) (char= x #\Return))) string)) ;; -(defun loadtxt (fname &key (delimiters '(#\Space #\Tab #\,)) (newlines '(#\Newline #\;))) +;; (defmacro apply* ((&rest funcl) expr) +;; (let ((syms (zip (mapcar #'gensym funcl) funcl))) +;; `(multiple-value-bind (,@(mapcar #'car syms)) ,expr +;; (values ,@(mapcar #'(lambda (x) `(apply ,(second x) ,(first x))) syms))))) + +;; (apply* (#'(lambda (x) (+ x 1)) #'(lambda (x) (- x 1))) (values 1 2)) + + +(defun loadtxt (fname &key (delimiters '(#\Space #\Tab #\,)) (newlines '(#\Newline #\;)) (skip-rows 0)) (let* ((f-string (file->string fname))) (multiple-value-bind (lns nrows) (split-seq #'(lambda (x) (member x newlines)) f-string) (unless (null lns) diff --git a/src/special/map.lisp b/src/special/map.lisp index 1edc1d2..c19b182 100644 --- a/src/special/map.lisp +++ b/src/special/map.lisp @@ -64,7 +64,7 @@ (let* ((v-x (slice~ x axis)) (st-x (aref (strides x) axis))) (loop :for i :from 0 :below (aref (the index-store-vector (dimensions x)) axis) - :collect (prog1 (funcall func (sub-tensor~ v-x nil)) + :collect (prog1 (funcall func (subtensor~ v-x nil)) (incf (slot-value v-x 'head) st-x)))))) (defmacro tensor-foldl (type func ten init &key (init-type (field-type type)) (key nil)) diff --git a/src/special/random.lisp b/src/special/random.lisp index 997d039..5f3ff5b 100644 --- a/src/special/random.lisp +++ b/src/special/random.lisp @@ -74,3 +74,8 @@ (rand (random 1d0)) (rande (draw-standard-exponential))))) +(defun randi (&optional dims (arg 2)) + (if dims + ;;Macro is used without hygiene: "arg". + (fill-tensor real-tensor ((coerce (random arg) 'double-float) (zeros dims 'real-tensor))) + (random arg))) diff --git a/src/utilities/functions.lisp b/src/utilities/functions.lisp index 6494995..e26251a 100644 --- a/src/utilities/functions.lisp +++ b/src/utilities/functions.lisp @@ -95,7 +95,7 @@ (if (atom car) (if (or (null car) (eq car tag)) (cadr lst) - (find-tag (cddr lst) tag)) + (find-tag (cdr lst) tag)) (or (find-tag car tag) (find-tag (cdr lst) tag))))) (defun ensure-args (args) ----------------------------------------------------------------------- Summary of changes: matlisp.asd | 4 +- packages.lisp | 7 +- src/base/generic-copy.lisp | 74 ++++++++---- src/base/permutation.lisp | 2 +- src/base/standard-tensor.lisp | 29 +++-- src/base/template.lisp | 108 +++++++------------ src/classes/foreign.lisp | 73 ++++++++++++ src/classes/numeric.lisp | 29 +++-- src/ffi/ffi-cffi-implementation-specific.lisp | 21 ++-- src/ffi/ffi-cffi.lisp | 28 +++-- src/ffi/foreign-vector.lisp | 20 ++-- src/lapack/chol.lisp | 4 +- src/lapack/eig.lisp | 4 +- src/lapack/geqr.lisp | 2 +- src/lapack/least-squares.lisp | 6 +- src/lapack/lu.lisp | 4 +- src/level-1/axpy.lisp | 27 ++--- src/level-1/copy.lisp | 147 +++++-------------------- src/level-1/dot.lisp | 31 +++--- src/level-1/scal.lisp | 26 ++--- src/level-1/sum.lisp | 4 +- src/level-1/swap.lisp | 2 +- src/level-2/gemv.lisp | 2 +- src/level-3/gemm.lisp | 2 +- src/reader/infix.lisp | 25 ++++- src/reader/loadsave.lisp | 10 ++- src/special/map.lisp ... [truncated message content] |
From: Akshay S. <ak...@us...> - 2013-11-15 10:50:20
|
This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "matlisp". The branch, tensor has been updated via 1f45e5ca07fb6ec6e83117fdb4a3ded5fa3e2b4f (commit) via e357e8266b9d8c1590fff4177057582577277846 (commit) via 98719db2d568c5b022b93d2520db95e89f210d77 (commit) via 705275944ef0cbd6caad409f5a3b3148641fca32 (commit) via 767a08754c5f93918b9bba5e3503f0286191f179 (commit) via 2b4808f24ea2cb5413b5af069f044a2f1ac1eef2 (commit) via 66de9b29137420f14bf37f794dbec1129664676f (commit) from 5481334c9a288f9ced6967f1995d4d30d0e39e2f (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 1f45e5ca07fb6ec6e83117fdb4a3ded5fa3e2b4f Author: Akshay Srinivasan <aks...@gm...> Date: Sun Oct 27 20:46:26 2013 -0700 Made changes to loadsave. diff --git a/src/reader/loadsave.lisp b/src/reader/loadsave.lisp index 2437607..5d51b9c 100644 --- a/src/reader/loadsave.lisp +++ b/src/reader/loadsave.lisp @@ -46,18 +46,40 @@ returning two values: the string and the number of bytes read." (multiple-value-bind (lns nrows) (split-seq #'(lambda (x) (member x newlines)) f-string) (unless (null lns) (let* ((ncols (second (multiple-value-list (split-seq #'(lambda (x) (member x delimiters)) (car lns))))) - (ret (zeros (list nrows ncols) 'real-tensor))) - (loop :for line :in lns - :for i := 0 :then (1+ i) - :do (loop :for num :in (split-seq #'(lambda (x) (member x delimiters)) line) - :for j := 0 :then (1+ j) - :do (setf (ref ret i j) (t/coerce (t/field-type real-tensor) (read-from-string num))))) + (ret (zeros (if (> ncols 1) (list nrows ncols) (list nrows)) 'real-tensor))) + (if (> ncols 1) + (loop :for line :in lns + :for i := 0 :then (1+ i) + :do (loop :for num :in (split-seq #'(lambda (x) (member x delimiters)) line) + :for j := 0 :then (1+ j) + :do (setf (ref ret i j) (t/coerce (t/field-type real-tensor) (read-from-string num))))) + (loop :for line :in lns + :for i := 0 :then (1+ i) + :do (setf (ref ret i) (t/coerce (t/field-type real-tensor) (read-from-string (car (split-seq #'(lambda (x) (member x delimiters)) line))))))) ret))))) (defun savetxt (fname mat &key (delimiter #\Tab) (newline #\Newline)) (with-open-file (out fname :direction :output :if-exists :overwrite :if-does-not-exist :create) - (let ((ncols (ncols mat))) - (loop :for i :from 0 :below (nrows mat) - :do (loop :for j :from 0 :below ncols - :do (format out "~a~a" (ref mat i j) (if (= j (1- ncols)) newline delimiter))))) + (cond + ((tensor-matrixp mat) + (let ((ncols (ncols mat))) + (loop :for i :from 0 :below (nrows mat) + :do (loop :for j :from 0 :below ncols + :do (format out "~a~a" (ref mat i j) (if (= j (1- ncols)) newline delimiter)))))) + ((tensor-vectorp mat) + (loop :for i :from 0 :below (aref (dimensions mat) 0) + :do (format out "~a~a" (ref mat i) newline))) + (t + (let ((dims (dimensions mat)) + (strd (strides mat))) + (format out ":head~a~a~a" delimiter (head mat) newline) + (format out ":dimensions~a" delimiter) + (loop :for i :from 0 :below (length dims) + :do (format out "~a~a" (aref dims i) (if (= i (1- (length dims))) newline delimiter))) + (format out ":strides~a" delimiter) + (loop :for i :from 0 :below (length dims) + :do (format out "~a~a" (aref strd i) (if (= i (1- (length dims))) newline delimiter))) + (let ((sto (store mat))) + (loop :for i :from 0 :below (length sto) + :do (format out "~a~a" (aref sto i) (if (= i (1- (length sto))) newline delimiter))))))) nil)) diff --git a/src/special/map.lisp b/src/special/map.lisp index 9dcb66b..1edc1d2 100644 --- a/src/special/map.lisp +++ b/src/special/map.lisp @@ -67,15 +67,18 @@ :collect (prog1 (funcall func (sub-tensor~ v-x nil)) (incf (slot-value v-x 'head) st-x)))))) -(defmacro tensor-foldl (type func ten init &optional (init-type (field-type type))) +(defmacro tensor-foldl (type func ten init &key (init-type (field-type type)) (key nil)) (using-gensyms (decl (ten init)) - (with-gensyms (sto idx of funcsym) + (with-gensyms (sto idx of funcsym keysym) `(let* (,@decl ,@(unless (symbolp func) `((,funcsym ,func))) + ,@(unless (symbolp key) + `((,keysym ,key))) (,sto (store ,ten))) (declare (type ,type ,ten) ,@(unless (symbolp func) `((type function ,funcsym))) + ,@(unless (symbolp key) `((type function ,keysym))) (type ,(store-type type) ,sto) ,@(when init-type `((type ,init-type ,init)))) @@ -85,5 +88,10 @@ (,of (strides ,ten))) :do (setf ,init (,@(if (symbolp func) `(,func) - `(funcall ,funcsym)) ,init (t/store-ref ,type ,sto ,of))))) + `(funcall ,funcsym)) ,init ,(recursive-append + (when key + (if (symbolp key) + `(,key) + `(funcall ,keysym))) + `(t/store-ref ,type ,sto ,of)))))) ,init)))) commit e357e8266b9d8c1590fff4177057582577277846 Author: Akshay Srinivasan <aks...@gm...> Date: Sun Oct 27 03:09:35 2013 -0700 Added reader/loadsave.lisp. diff --git a/matlisp.asd b/matlisp.asd index 0afc593..8b57116 100644 --- a/matlisp.asd +++ b/matlisp.asd @@ -181,10 +181,10 @@ (:file "mplusminus") #+nil (:file "mtimesdivide"))) - #+nil (:module "matlisp-reader" - :pathname "reader" - :components ((:file "infix"))))) + :pathname "reader" + :components (#+nil(:file "infix") + (:file "loadsave"))))) ;; (defclass f2cl-cl-source-file (asdf:cl-source-file) diff --git a/src/reader/loadsave.lisp b/src/reader/loadsave.lisp new file mode 100644 index 0000000..2437607 --- /dev/null +++ b/src/reader/loadsave.lisp @@ -0,0 +1,63 @@ +(in-package #:matlisp) + +#+(not :sbcl) +(defun file->string (path) + "Sucks up an entire file from PATH into a freshly-allocated string, +returning two values: the string and the number of bytes read." + (declare (optimize (safety 0) (speed 3))) + (with-open-file (s path :external-format :iso8859-1) + (let* ((len (file-length s)) + (data (make-array len :element-type 'standard-char))) + (values data (read-sequence data s))))) + +#+sbcl +(defun file->string (path) +"Sucks up an entire file from PATH into a freshly-allocated string, +returning two values: the string and the number of bytes read." + (let* ((fsize (with-open-file (s path) + (file-length s))) + (data (make-array fsize :element-type 'standard-char)) + (fd (sb-posix:open path 0))) + (unwind-protect (sb-posix:read fd (sb-sys:vector-sap data) fsize) + (sb-posix:close fd)) + (values data fsize))) +;; +(definline split-seq (test seq &optional (filter-empty? t)) + "Split a string, wherever the given character occurs." + (loop :for i :from (1- (length seq)) :downto -1 + :with prev := (length seq) + :with split-list := nil + :with split-count := 0 + :do (when (or (< i 0) (funcall test (aref seq i))) + (let ((str (subseq seq (1+ i) prev))) + (when (or (< (1+ i) prev) (not filter-empty?)) + (incf split-count) + (push str split-list)) + (setf prev i))) + :finally (return (values split-list split-count)))) +;; +(defun splitlines (string) + "Split the given string wherever the Carriage-return occurs." + (split-seq #'(lambda (x) (or (char= x #\Newline) (char= x #\Return))) string)) + +;; +(defun loadtxt (fname &key (delimiters '(#\Space #\Tab #\,)) (newlines '(#\Newline #\;))) + (let* ((f-string (file->string fname))) + (multiple-value-bind (lns nrows) (split-seq #'(lambda (x) (member x newlines)) f-string) + (unless (null lns) + (let* ((ncols (second (multiple-value-list (split-seq #'(lambda (x) (member x delimiters)) (car lns))))) + (ret (zeros (list nrows ncols) 'real-tensor))) + (loop :for line :in lns + :for i := 0 :then (1+ i) + :do (loop :for num :in (split-seq #'(lambda (x) (member x delimiters)) line) + :for j := 0 :then (1+ j) + :do (setf (ref ret i j) (t/coerce (t/field-type real-tensor) (read-from-string num))))) + ret))))) + +(defun savetxt (fname mat &key (delimiter #\Tab) (newline #\Newline)) + (with-open-file (out fname :direction :output :if-exists :overwrite :if-does-not-exist :create) + (let ((ncols (ncols mat))) + (loop :for i :from 0 :below (nrows mat) + :do (loop :for j :from 0 :below ncols + :do (format out "~a~a" (ref mat i j) (if (= j (1- ncols)) newline delimiter))))) + nil)) commit 98719db2d568c5b022b93d2520db95e89f210d77 Author: Akshay Srinivasan <aks...@gm...> Date: Sun Oct 27 01:41:17 2013 -0700 Saving state. diff --git a/src/lapack/gels.lisp b/src/lapack/gels.lisp deleted file mode 100644 index 0d8008d..0000000 --- a/src/lapack/gels.lisp +++ /dev/null @@ -1,145 +0,0 @@ -;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Package: :matlisp; Base: 10 -*- - -(in-package "MATLISP") - -(defgeneric gelsy! (a b rcond) - (:documentation "Destructive version of GELSY. See GELSY.")) - -(defgeneric gelsy (a b rcond) - (:documentation - " - Syntax - ======= - - (GELSY A B &key TOL) - - INPUT - ----- - A A Matlisp matrix of size M x N - B A Matlisp matrix of size M x P - RCOND A condition number - - OUTPUT - ------ - X A Matlisp matrix of size N x NRHS - RANK An integer - - Purpose - ======= - - Compute the minimum-norm solution to a real linear least - squares problem: - minimize || A * X - B || - using a complete orthogonal factorization of A. A is an M-by-N - matrix which may be rank-deficient. - - Several right hand side vectors b and solution vectors x can be - handled in a single call; they are stored as the columns of the - M-by-NRHS right hand side matrix B and the N-by-NRHS solution - matrix X. - - The routine first computes a QR factorization with column pivoting: - A * P = Q * [ R11 R12 ] - [ 0 R22 ] - with R11 defined as the largest leading submatrix whose estimated - condition number is less than 1/RCOND. The order of R11, RANK, - is the effective rank of A. - - Then, R22 is considered to be negligible, and R12 is annihilated - by orthogonal transformations from the right, arriving at the - complete orthogonal factorization: - A * P = Q * [ T11 0 ] * Z - [ 0 0 ] - The minimum-norm solution is then - X = P * Z' [ inv(T11)*Q1'*B ] - [ 0 ] - where Q1 consists of the first RANK columns of Q. - - This routine is basically identical to the original xGELSX except - three differences: - o The call to the subroutine xGEQPF has been substituted by the - the call to the subroutine xGEQP3. This subroutine is a Blas-3 - version of the QR factorization with column pivoting. - o Matrix B (the right hand side) is updated with Blas-3. - o The permutation of matrix B (the right hand side) is faster and - more simple. - - Further Details - =============== - - Based on contributions by - A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA - E. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain - G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain - - ===================================================================== -")) - -(defun check-info (info function-name) - (unless (= info 0) - (error "~a: error in argument ~d" function-name (- info)))) - -(defun dgelsy-workspace-inquiry (m n nrhs a lda b ldb jpvt rcond rank) - (let ((work (allocate-real-store 1))) - (multiple-value-bind - (store-a store-b store-jpvt rank store-work info) - (lapack::dgelsy m n nrhs (store a) lda (store b) ldb jpvt rcond rank - work -1 0) - (declare (ignore store-a store-b store-jpvt rank store-work)) - (check-info info "dgelsy")) - (values (ceiling (realpart (aref work 0)))))) - -(defmethod gelsy! ((a real-matrix) (b real-matrix) rcond) - (let* ((m (nrows a)) - (n (ncols a)) - (nrhs (ncols b)) - (jpvt (allocate-integer4-store n 0)) - (lda m) - (ldb (max n m)) - (b-arg b)) - (when (and (< m n)) - ;; In this case we need to extend the matrix which stores B - ;; since it will be used to store the computation result - (setq b-arg (make-real-matrix n nrhs)) - (dotimes (i m) - (dotimes (j nrhs) - (setf (matrix-ref b-arg i j) - (matrix-ref b i j))))) - (let* ((lwork (dgelsy-workspace-inquiry m n nrhs a lda b-arg ldb jpvt - rcond 0)) - (work (allocate-real-store lwork))) - (assert (= m (nrows b))) - (multiple-value-bind - (store-a store-b store-jpvt rank store-work info) - (lapack::dgelsy m n nrhs (store a) lda (store b-arg) ldb jpvt rcond 0 - work lwork 0) - (declare (ignore store-a store-jpvt store-work)) - (check-info info "dgelsy") - (let ((x (make-real-matrix n nrhs))) - ;; extract the matrix X from B - (dotimes (i n) - (dotimes (j nrhs) - (setf (matrix-ref x i j) - (aref store-b (fortran-matrix-indexing i j n))))) - (values x rank)))))) - -(defmethod gelsy ((a real-matrix) (b real-matrix) rcond) - (gelsy! (copy a) (copy b) rcond)) - -;; Example - -#| - -(let* ((m 100) - (n 100) - (a (rand m n)) - (x (rand n 1)) - (b (m* a x)) - (eps (coerce (expt 2 -52) 'double-float)) - (rcond (* eps (max m n)))) - (multiple-value-bind (r1 rank) - (matlisp::gelsy a b rcond) - (list rank - (norm (m- x r1))))) - -|# diff --git a/src/lapack/lu.lisp b/src/lapack/lu.lisp index fcd9d92..1c5e7f7 100644 --- a/src/lapack/lu.lisp +++ b/src/lapack/lu.lisp @@ -136,77 +136,11 @@ By default WITH-L,WITH-U,WITH-P. ")) -;; (defmethod lu ((a standard-tensor) &optional split-lu?) -;; (let ((lu (getrf! (copy a)) - -#+nil -(defmacro make-lu (tensor-class) - (let* ((opt (if-ret (get-tensor-class-optimization-hashtable tensor-class) - (error 'tensor-cannot-find-optimization :tensor-class tensor-class))) - (matrix-class (getf opt :matrix))) - `(defmethod lu ((A ,matrix-class) &optional (split-lu? t)) - (multiple-value-bind (lu ipiv info) - (getrf! (with-order :col-major - (,(getf opt :copy) A (,(getf opt :zero-maker) (dimensions A))))) - (declare (ignore info)) - (let* ((n (nrows a)) - (m (ncols a)) - (p (min n m))) - (declare (type fixnum n m p)) - ;; Extract the lower triangular part, if requested - (if split-lu? - (if (= p m) - (let*-typed ((umat (,(getf opt :zero-maker) (list p m)) :type ,matrix-class) - ;; - (u.rstd (row-stride umat) :type index-type) - (u.cstd (col-stride umat) :type index-type) - (u.of (head umat) :type index-type) - (u.sto (store umat) :type ,(linear-array-type (getf opt :store-type))) - ;; - (lu.rstd (row-stride lu) :type index-type) - (lu.cstd (col-stride lu) :type index-type) - (lu.of (head lu) :type index-type) - (lu.sto (store lu) :type ,(linear-array-type (getf opt :store-type)))) - (very-quickly - (loop :for i :of-type index-type :from 0 :below p - :do (let-typed ((lu.of-ii lu.of :type index-type)) - (loop :repeat (- m i) - :do (progn - (,(getf opt :reader-writer) lu.sto lu.of u.sto u.of) - (,(getf opt :value-writer) (,(getf opt :fid+)) lu.sto lu.of) - (incf lu.of lu.cstd) - (incf u.of u.cstd))) - (,(getf opt :value-writer) (,(getf opt :fid*)) lu.sto lu.of-ii) - (incf lu.of (- lu.rstd (the index-type (* (- m i 1) lu.cstd)))) - (incf u.of (- u.rstd (the index-type (* (- m i 1) u.cstd))))))) - (values lu umat ipiv)) - (let*-typed ((lmat (,(getf opt :zero-maker) (list n p)) :type ,matrix-class) - ;; - (l.rstd (row-stride lmat) :type index-type) - (l.cstd (col-stride lmat) :type index-type) - (l.of (head lmat) :type index-type) - (l.sto (store lmat) :type ,(linear-array-type (getf opt :store-type))) - ;; - (lu.rstd (row-stride lu) :type index-type) - (lu.cstd (col-stride lu) :type index-type) - (lu.of (head lu) :type index-type) - (lu.sto (store lu) :type ,(linear-array-type (getf opt :store-type)))) - (very-quickly - (loop :for j :of-type index-type :from 0 :below p - :do (progn - (,(getf opt :value-writer) (,(getf opt :fid*)) l.sto l.of) - (loop :repeat (- n j 1) - :do (progn - (incf lu.of lu.rstd) - (incf l.of l.rstd) - (,(getf opt :reader-writer) lu.sto lu.of l.sto l.of) - (,(getf opt :value-writer) (,(getf opt :fid+)) lu.sto lu.of))) - (incf lu.of (- lu.cstd (the index-type (* (- n j 2) lu.rstd)))) - (incf l.of (- l.cstd (the index-type (* (- n j 2) l.rstd))))))) - (values lmat lu ipiv))) - (values lu ipiv))))))) - - +;; (defmethod lu ((a standard-tensor) &optional (split-lu? t)) +;; (multiple-value-bind (lu perm) (getrf! (copy a)) +;; (if (not split-lu?) (values lu perm) +;; (let* ((min (lvec-min (dimensions lu))) +;; ( ;; (deft/generic (t/lapack-getrs-func #'subtypep) sym ()) (deft/method t/lapack-getrs-func (sym real-tensor) () diff --git a/src/level-1/axpy.lisp b/src/level-1/axpy.lisp index d6dd42a..78cf827 100644 --- a/src/level-1/axpy.lisp +++ b/src/level-1/axpy.lisp @@ -165,3 +165,7 @@ ") (:method (alpha x (y standard-tensor)) (axpy! alpha x (copy y)))) + +(defmethod axpy (alpha (x standard-tensor) (y (eql nil))) + (let ((tmp (zeros (dimensions x) (class-of x)))) + (axpy! alpha x tmp))) diff --git a/src/level-1/copy.lisp b/src/level-1/copy.lisp index c06dcd2..c90bbff 100644 --- a/src/level-1/copy.lisp +++ b/src/level-1/copy.lisp @@ -120,6 +120,35 @@ ;; ;;This macro is used for interfacing with lapack ;;Only to be used with matrices! + +#| +(deft/generic (t/copy-triangle! #'subtypep) sym (a b &optional upper?)) +(deft/method t/copy-triangle! (sym standard-tensor) (a b &optional (upper? t)) + (using-gensyms (decl (diag a b)) + (with-gensyms (sto-a sto-b strd-a strd-b dof-a dof-b of-a of-b) + `(let* (,@decl + (,sto-a (store ,a)) + (,strd-a (strides ,a)) + (,sto-b (store ,b)) + (,strd-b (strides ,b))) + (declare (type ,sym ,a ,b) + (type ,(store-type sym) ,sto-a ,sto-b) + (type index-store-vector ,strd-a ,strd-b)) + (ecase ,diag + (t + (with-marking + (very-quickly + (:mark* ((ndiags (min (nrows ,a) (ncols ,a)))) + (loop :for i :from 0 :below ndiags + :for ,dof-a :of-type index-type := (head ,a) :then (+ ,dof-a (:mark (lvec-foldr #'+ ,strd-a) :type index-type)) + :for ,dof-b :of-type index-type := (head ,b) :then (+ ,dof-b (:mark (lvec-foldr #'+ ,strd-b) :type index-type)) + :do (loop :for j :from 0 :below ,(if upper? `(1+ i) `(- ndiags i)) + :for ,of-a :of-type index-type := ,dof-a :then (,(if upper? '- '+) ,of-a (:mark (aref ,strd-a 0))) + :for ,of-b :of-type index-type := ,dof-b :then (,(if upper? '- '+) ,of-b (:mark (aref ,strd-b 0))) + :do (t/store-set ,sym (t/store-ref ,sym ,sto-a ,of-a) ,sto-b ,of-b))))))) + + ,b)))) +;; (deft/generic (t/copy-triangle! #'subtypep) sym (a b &optional upper?)) (deft/method t/copy-triangle! (sym standard-tensor) (a b &optional (upper? t)) (using-gensyms (decl (a b)) @@ -162,6 +191,37 @@ :for ,of-b :of-type index-type := (head ,b) :then (+ ,of-b (:mark (lvec-foldr #'+ (strides ,b)) :type index-type)) :do (t/store-set ,sym ,@(if num? `(,a) `((t/store-ref ,sym ,sto-a ,of-a))) ,sto-b ,of-b))))) ,b)))) + +;; +(defgeneric copy-triangle! (x y &key upper? diag?) + (:method :before ((x standard-tensor) (y standard-tensor) &key upper? diag?) + (assert (and (tensor-matrixp x) (tensor-matrixp y) + (= (lvec-min (dimensions x)) (lvec-min (dimensions y)))) + nil 'tensor-dimension-mismatch))) + + +(defmethod copy-triangle! ((x standard-tensor) (y standard-tensor) &key (upper? t) (diag? t)) + (let ((clx (class-name (class-of x))) + (cly (class-name (class-of y)))) + (assert (and (member clx *tensor-type-leaves*) + (member cly *tensor-type-leaves*) + (eql clx cly)) + nil 'tensor-abstract-class :tensor-class (list clx cly)) + (compile-and-eval + (let ((expr `()))) + `(defmethod copy-triangle! ((x ,clx) (y ,cly) &key (upper? t) (diag? t)) + (ecase diag? + (t ;;copy diagonal + (if upper? (t/copy-triangle! ,clx x y t) (t/copy-triangle! ,clx x y nil))) + (number + (let ((num (t/coerce ,(t/field-type clx) diag?))) + (if upper? (t/copy-triangle! ,clx x y t) (t/copy-triangle! ,clx x y nil)) + (t/copy-diagonal! ,clx num y t))) + (nil + (let ((num + +|# + ;; (defmethod copy! :before ((x standard-tensor) (y standard-tensor)) (assert (very-quickly (lvec-eq (the index-store-vector (dimensions x)) (the index-store-vector (dimensions y)) #'=)) nil commit 705275944ef0cbd6caad409f5a3b3148641fca32 Author: Akshay Srinivasan <aks...@gm...> Date: Sat Oct 12 03:10:51 2013 -0700 Added least-squares to asd file. diff --git a/matlisp.asd b/matlisp.asd index b4b9ac0..0afc593 100644 --- a/matlisp.asd +++ b/matlisp.asd @@ -164,7 +164,8 @@ :depends-on ("matlisp-base" "matlisp-classes" "matlisp-level-1" "matlisp-level-2" "matlisp-level-3") :components ((:file "lu") (:file "chol") - (:file "eig"))) + (:file "eig") + (:file "least-squares"))) (:module "matlisp-special" :pathname "special" :depends-on ("matlisp-base" "matlisp-classes" "matlisp-level-1" "matlisp-level-2" "matlisp-level-3") commit 767a08754c5f93918b9bba5e3503f0286191f179 Author: Akshay Srinivasan <aks...@gm...> Date: Sat Oct 12 03:09:32 2013 -0700 Moved gels.lisp to least-squares.lisp, replaced its contents with new interface. diff --git a/src/lapack/least-squares.lisp b/src/lapack/least-squares.lisp new file mode 100644 index 0000000..7816998 --- /dev/null +++ b/src/lapack/least-squares.lisp @@ -0,0 +1,151 @@ +(in-package :matlisp) + +(deft/generic (t/lapack-gelsy-func #'subtypep) sym ()) +(deft/method t/lapack-gelsy-func (sym real-tensor) () + 'dgelsy) + +(definline mzgelsy (m n nrhs a lda b ldb jpvt rcond rank work lwork info &optional (head-a 0) (head-b 0)) + (zgelsy m n nrhs a lda b ldb jpvt rcond rank work lwork (t/store-allocator complex-tensor n) info head-a head-b)) +(deft/method t/lapack-gelsy-func (sym complex-tensor) () + 'mzgelsy) +;; +(deft/generic (t/lapack-gelsy! #'subtypep) sym (A lda B ldb rcond work)) +(deft/method t/lapack-gelsy! (sym blas-numeric-tensor) (A lda B ldb rcond work) + (using-gensyms (decl (A lda B ldb rcond work)) + (with-gensyms (jpvt) + `(let* (,@decl + (,jpvt (make-array (ncols ,A) :element-type '(unsigned-byte 32) :initial-element 0))) + (declare (type ,sym ,A ,B) + (type index-type ,lda ,ldb) + ;;BEWARE: This will throw an error, if you use (simple-array (complex double-float) (*)) for store. + (type ,(store-element-type sym) ,rcond) + (type ,(store-type sym) work) + (type (simple-array (unsigned-byte 32) (*)) ,jpvt)) + (,(macroexpand-1 `(t/lapack-gelsy-func ,sym)) + (nrows ,A) (ncols ,A) (ncols ,B) + (the ,(store-type sym) (store ,A)) ,lda + (the ,(store-type sym) (store ,B)) ,ldb + ,jpvt ,rcond 0 + ,work (t/store-size ,sym ,work) + 0 + (the index-type (head ,A)) (the index-type (head ,B))))))) + +(deft/generic (t/lapack-gelsy-workspace-inquiry #'subtypep) sym (m n nrhs)) +(deft/method t/lapack-gelsy-workspace-inquiry (sym blas-numeric-tensor) (m n nrhs) + (using-gensyms (decl (m n nrhs)) + (with-gensyms (xxx) + `(let* (,@decl + (,xxx (t/store-allocator ,sym 1))) + (declare (type index-type ,m ,n ,nrhs) + (type ,(store-type sym) ,xxx)) + (,(macroexpand-1 `(t/lapack-gelsy-func ,sym)) + ,m ,n ,nrhs + ,xxx ,m + ,xxx ,m + ,xxx (t/coerce (t/store-element-type ,sym) 0) 0 + ,xxx -1 + 0) + (ceiling (t/frealpart ,(field-type sym) (t/store-ref ,sym ,xxx 0))))))) +;; + +(defgeneric gelsy (A B &optional rcond) + (:documentation " + Syntax + ======= + + (GELSY A B &key TOL) + + INPUT + ----- + A A Matlisp matrix of size M x N + B A Matlisp matrix of size M x P + RCOND A condition number + + OUTPUT + ------ + X A Matlisp matrix of size N x NRHS + RANK An integer + + Purpose + ======= + + Compute the minimum-norm solution to a real linear least + squares problem: + minimize || A * X - B || + using a complete orthogonal factorization of A. A is an M-by-N + matrix which may be rank-deficient. + + Several right hand side vectors b and solution vectors x can be + handled in a single call; they are stored as the columns of the + M-by-NRHS right hand side matrix B and the N-by-NRHS solution + matrix X. + + The routine first computes a QR factorization with column pivoting: + A * P = Q * [ R11 R12 ] + [ 0 R22 ] + with R11 defined as the largest leading submatrix whose estimated + condition number is less than 1/RCOND. The order of R11, RANK, + is the effective rank of A. + + Then, R22 is considered to be negligible, and R12 is annihilated + by orthogonal transformations from the right, arriving at the + complete orthogonal factorization: + A * P = Q * [ T11 0 ] * Z + [ 0 0 ] + The minimum-norm solution is then + X = P * Z' [ inv(T11)*Q1'*B ] + [ 0 ] + where Q1 consists of the first RANK columns of Q. + + This routine is basically identical to the original xGELSX except + three differences: + o The call to the subroutine xGEQPF has been substituted by the + the call to the subroutine xGEQP3. This subroutine is a Blas-3 + version of the QR factorization with column pivoting. + o Matrix B (the right hand side) is updated with Blas-3. + o The permutation of matrix B (the right hand side) is faster and + more simple. + + Further Details + =============== + + Based on contributions by + A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA + E. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain + G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain + + ===================================================================== +") + (:method :before ((A standard-tensor) (B standard-tensor) &optional rcond) + (assert (and (tensor-matrixp A) (tensor-matrixp B) (= (nrows A) (nrows B))) nil 'tensor-dimension-mismatch) + (assert (or (null rcond) (> rcond 0)) nil 'invalid-value :expected '(> rcond 0) :given rcond :message "Invalid rcond."))) + +(defmethod gelsy ((A standard-tensor) (B standard-tensor) &optional (rcond *default-rcond*)) + (let ((cla (class-name (class-of A))) + (clb (class-name (class-of B)))) + (assert (and (member cla *tensor-type-leaves*) (member clb *tensor-type-leaves*)) + nil 'tensor-abstract-class :tensor-class (list cla clb)) + (cond + ((eql cla clb) + (compile-and-eval + `(defmethod gelsy ((oA ,cla) (B ,clb) &optional (rcond *default-rcond*)) + (let* ((A (let ((*default-stride-ordering* :col-major)) (copy oA))) + (lwork (max (t/lapack-gelsy-workspace-inquiry ,cla (nrows A) (ncols A) (ncols B)) 1)) + (work (t/store-allocator ,cla lwork))) + (declare (type index-type lwork) + (type ,(store-type cla) work) + (type ,cla A)) + (let* ((rank-A 0) + (mn (max (nrows A) (ncols A))) + (X (let ((*default-stride-ordering* :col-major)) (zeros (list mn (ncols B)) ',cla)))) + (copy! B (sub-tensor~ X `((0 * ,(nrows A)) (* * *)) t)) + (multiple-value-bind (sto-a sto-b jpvt rank work-out info) (t/lapack-gelsy! ,cla A (or (blas-matrix-compatiblep A #\N) 0) X (or (blas-matrix-compatiblep X #\N) 0) rcond work) + ;;TODO: Implement inverse permutation-action, and return jpvt. + (declare (ignore sto-a sto-b work-out jpvt)) + (setf rank-a rank) + (unless (= info 0) + (error "gelsy returned ~a." info))) + (values (copy (sub-tensor~ X `((0 * ,(ncols A)) (* * *)) t)) rank-a))))) + (gelsy A B rcond)) + (t + (error "Don't know how to apply getrs! to classes ~a." (list cla clb)))))) commit 2b4808f24ea2cb5413b5af069f044a2f1ac1eef2 Author: Akshay Srinivasan <aks...@gm...> Date: Sat Oct 12 03:01:41 2013 -0700 Fixed silly bug, related to output spacing. diff --git a/src/foreign-core/lapack.lisp b/src/foreign-core/lapack.lisp index 1dc05ed..5941cc4 100644 --- a/src/foreign-core/lapack.lisp +++ b/src/foreign-core/lapack.lisp @@ -2000,5 +2000,5 @@ (rank :integer :output) (work (* :complex-double-float) :workspace-output) (lwork :integer :input) - (rwork (* :double-float) :workspace-output) + (rwork (* :double-float) :workspace) ;;Not workspace-output (!) (info :integer :output)) commit 66de9b29137420f14bf37f794dbec1129664676f Author: Akshay Srinivasan <aks...@gm...> Date: Sat Oct 12 02:52:07 2013 -0700 o Added interface for gelsy. diff --git a/packages.lisp b/packages.lisp index b0aa7ca..6d8868c 100644 --- a/packages.lisp +++ b/packages.lisp @@ -154,7 +154,7 @@ #:dgeqrf #:zgeqrf #:dgeqp3 #:zgeqp3 #:dorgqr #:zungqr #:dpotrs #:zpotrs #:dpotrf #:zpotrf - #:dgelsy) + #:dgelsy #:zgelsy) (:documentation "LAPACK routines")) (defpackage "MATLISP-DFFTPACK" diff --git a/src/base/template.lisp b/src/base/template.lisp index cd7daf8..65a296c 100644 --- a/src/base/template.lisp +++ b/src/base/template.lisp @@ -130,6 +130,10 @@ (deft/method t/compute-store-size (sym standard-tensor) (size) size) +(deft/generic (t/store-size #'subtypep) sym (ele)) +(deft/method t/store-size (sym standard-tensor) (ele) + `(length ,ele)) + (deft/generic (t/store-allocator #'subtypep) sym (size &optional initial-element)) (deft/method t/store-allocator (sym standard-tensor) (size &optional initial-element) (let ((size-sym (gensym)) diff --git a/src/base/tweakable.lisp b/src/base/tweakable.lisp index 86dca90..cab998f 100644 --- a/src/base/tweakable.lisp +++ b/src/base/tweakable.lisp @@ -28,6 +28,11 @@ which case, may lead to memory error. Use at your own risk. ") +(defparameter *default-rcond* 1d-15 + " + The default value of condition number to be used for + determining the rank of a matrix (used in gelsy). +") ;;Level 1--------------------------------------------------------;; (defparameter *real-l1-fcall-lb* 5000 "If the size of the array is less than this parameter, the diff --git a/src/classes/numeric.lisp b/src/classes/numeric.lisp index f360bf9..632a85a 100644 --- a/src/classes/numeric.lisp +++ b/src/classes/numeric.lisp @@ -64,6 +64,9 @@ (deft/method t/compute-store-size (sym complex-numeric-tensor) (size) `(* 2 ,size)) + (deft/method t/store-size (sym complex-numeric-tensor) (vec) + `(/ (length ,vec) 2)) + (deft/method t/store-ref (sym complex-numeric-tensor) (store idx) (let ((store-s (gensym)) (idx-s (gensym)) diff --git a/src/foreign-core/lapack.lisp b/src/foreign-core/lapack.lisp index 1c94e74..1dc05ed 100644 --- a/src/foreign-core/lapack.lisp +++ b/src/foreign-core/lapack.lisp @@ -1578,9 +1578,9 @@ (m :integer :input) (n :integer :input) (nrhs :integer :input) - (a (* :double-float) :input-output) + (a (* :double-float :inc head-a) :input-output) (lda :integer :input) - (b (* :double-float) :input-output) + (b (* :double-float :inc head-b) :input-output) (ldb :integer :input) (jpvt (* :integer) :input-output) (rcond :double-float :input) @@ -1865,3 +1865,140 @@ (b (* :complex-double-float :inc head-b) :input-output) (ldb :integer :input) (info :integer :output)) + +(def-fortran-routine zgelsy :void + " + SUBROUTINE ZGELSY( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, + WORK, LWORK, RWORK, INFO ) + Purpose + ======= + + ZGELSY computes the minimum-norm solution to a complex linear least + squares problem: + minimize || A * X - B || + using a complete orthogonal factorization of A. A is an M-by-N + matrix which may be rank-deficient. + + Several right hand side vectors b and solution vectors x can be + handled in a single callthey are stored as the columns of the + M-by-NRHS right hand side matrix B and the N-by-NRHS solution + matrix X. + + The routine first computes a QR factorization with column pivoting: + A * P = Q * [ R11 R12 ] + [ 0 R22 ] + with R11 defined as the largest leading submatrix whose estimated + condition number is less than 1/RCOND. The order of R11, RANK, + is the effective rank of A. + + Then, R22 is considered to be negligible, and R12 is annihilated + by unitary transformations from the right, arriving at the + complete orthogonal factorization: + A * P = Q * [ T11 0 ] * Z + [ 0 0 ] + The minimum-norm solution is then + X = P * Z' [ inv(T11)*Q1'*B ] + [ 0 ] + where Q1 consists of the first RANK columns of Q. + + This routine is basically identical to the original xGELSX except + three differences: + o The permutation of matrix B (the right hand side) is faster and + more simple. + o The call to the subroutine xGEQPF has been substituted by the + the call to the subroutine xGEQP3. This subroutine is a Blas-3 + version of the QR factorization with column pivoting. + o Matrix B (the right hand side) is updated with Blas-3. + + Arguments + ========= + + M (input) INTEGER + The number of rows of the matrix A. M >= 0. + + N (input) INTEGER + The number of columns of the matrix A. N >= 0. + + NRHS (input) INTEGER + The number of right hand sides, i.e., the number of + columns of matrices B and X. NRHS >= 0. + + A (input/output) COMPLEX*16 array, dimension (LDA,N) + On entry, the M-by-N matrix A. + On exit, A has been overwritten by details of its + complete orthogonal factorization. + + LDA (input) INTEGER + The leading dimension of the array A. LDA >= max(1,M). + + B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) + On entry, the M-by-NRHS right hand side matrix B. + On exit, the N-by-NRHS solution matrix X. + + LDB (input) INTEGER + The leading dimension of the array B. LDB >= max(1,M,N). + + JPVT (input/output) INTEGER array, dimension (N) + On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted + to the front of AP, otherwise column i is a free column. + On exit, if JPVT(i) = k, then the i-th column of A*P + was the k-th column of A. + + RCOND (input) DOUBLE PRECISION + RCOND is used to determine the effective rank of A, which + is defined as the order of the largest leading triangular + submatrix R11 in the QR factorization with pivoting of A, + whose estimated condition number < 1/RCOND. + + RANK (output) INTEGER + The effective rank of A, i.e., the order of the submatrix + R11. This is the same as the order of the submatrix T11 + in the complete orthogonal factorization of A. + + WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK)) + On exit, if INFO = 0, WORK(1) returns the optimal LWORK. + + LWORK (input) INTEGER + The dimension of the array WORK. + The unblocked strategy requires that: + LWORK >= MN + MAX( 2*MN, N+1, MN+NRHS ) + where MN = min(M,N). + The block algorithm requires that: + LWORK >= MN + MAX( 2*MN, NB*(N+1), MN+MN*NB, MN+NB*NRHS ) + where NB is an upper bound on the blocksize returned + by ILAENV for the routines ZGEQP3, ZTZRZF, CTZRQF, ZUNMQR, + and ZUNMRZ. + + If LWORK = -1, then a workspace query is assumedthe routine + only calculates the optimal size of the WORK array, returns + this value as the first entry of the WORK array, and no error + message related to LWORK is issued by XERBLA. + + RWORK (workspace) DOUBLE PRECISION array, dimension (2*N) + + INFO (output) INTEGER + = 0: successful exit + < 0: if INFO = -i, the i-th argument had an illegal value + + Further Details + =============== + + Based on contributions by + A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA + E. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain + G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain +" + (m :integer :input) + (n :integer :input) + (nrhs :integer :input) + (a (* :complex-double-float :inc head-a) :input-output) + (lda :integer :input) + (b (* :complex-double-float :inc head-b) :input-output) + (ldb :integer :input) + (jpvt (* :integer) :input-output) + (rcond :complex-double-float :input) + (rank :integer :output) + (work (* :complex-double-float) :workspace-output) + (lwork :integer :input) + (rwork (* :double-float) :workspace-output) + (info :integer :output)) diff --git a/src/lapack/eig.lisp b/src/lapack/eig.lisp index f0a92da..ed67faf 100644 --- a/src/lapack/eig.lisp +++ b/src/lapack/eig.lisp @@ -45,7 +45,7 @@ ,wr ,wi (if ,vl (the ,(store-type sym) (store ,vl)) (cffi:null-pointer)) (if ,vl ,ldvl 1) (if ,vr (the ,(store-type sym) (store ,vr)) (cffi:null-pointer)) (if ,vr ,ldvr 1) - ,work (length ,work) + ,work (t/store-size ,sym ,work) 0 (the index-type (head ,A)) (if ,vl (the index-type (head ,vl)) 0) (if ,vr (the index-type (head ,vr)) 0))))) ;; ----------------------------------------------------------------------- Summary of changes: matlisp.asd | 9 ++- packages.lisp | 2 +- src/base/template.lisp | 4 + src/base/tweakable.lisp | 5 ++ src/classes/numeric.lisp | 3 + src/foreign-core/lapack.lisp | 141 +++++++++++++++++++++++++++++++++++++- src/lapack/eig.lisp | 2 +- src/lapack/gels.lisp | 145 --------------------------------------- src/lapack/least-squares.lisp | 151 +++++++++++++++++++++++++++++++++++++++++ src/lapack/lu.lisp | 76 ++------------------- src/level-1/axpy.lisp | 4 + src/level-1/copy.lisp | 60 ++++++++++++++++ src/reader/loadsave.lisp | 85 +++++++++++++++++++++++ src/special/map.lisp | 14 +++- 14 files changed, 474 insertions(+), 227 deletions(-) delete mode 100644 src/lapack/gels.lisp create mode 100644 src/lapack/least-squares.lisp create mode 100644 src/reader/loadsave.lisp hooks/post-receive -- matlisp |
From: Akshay S. <ak...@us...> - 2013-10-02 02:24:38
|
This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "matlisp". The branch, tensor has been updated via 5481334c9a288f9ced6967f1995d4d30d0e39e2f (commit) from 6f9bed41c2556366ed4f8bc79516e8c3c3a19ee0 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- ----------------------------------------------------------------------- Summary of changes: src/level-1/copy.lisp | 30 ++++++++++++++++++++++-------- 1 files changed, 22 insertions(+), 8 deletions(-) hooks/post-receive -- matlisp |
From: Akshay S. <ak...@us...> - 2013-10-02 02:24:08
|
This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "matlisp". The branch, classy has been updated via 5481334c9a288f9ced6967f1995d4d30d0e39e2f (commit) via 6f9bed41c2556366ed4f8bc79516e8c3c3a19ee0 (commit) from 5304b7204035eab0b7ac2664a6e1949a0689e741 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 5481334c9a288f9ced6967f1995d4d30d0e39e2f Author: Akshay Srinivasan <aks...@gm...> Date: Mon Sep 30 16:40:39 2013 -0700 Fixed the copy-triangle macro, added copy-diagonal. diff --git a/src/level-1/copy.lisp b/src/level-1/copy.lisp index 3399780..c06dcd2 100644 --- a/src/level-1/copy.lisp +++ b/src/level-1/copy.lisp @@ -120,8 +120,8 @@ ;; ;;This macro is used for interfacing with lapack ;;Only to be used with matrices! -(deft/generic (t/copy-triangle! #'subtypep) sym (a b &optional upper? diag?)) -(deft/method t/copy-triangle! (sym standard-tensor) (a b &optional (upper? nil) (diag? t)) +(deft/generic (t/copy-triangle! #'subtypep) sym (a b &optional upper?)) +(deft/method t/copy-triangle! (sym standard-tensor) (a b &optional (upper? t)) (using-gensyms (decl (a b)) (with-gensyms (sto-a sto-b strd-a strd-b dof-a dof-b of-a of-b) `(let* (,@decl @@ -141,13 +141,27 @@ :do (loop :for j :from 0 :below ,(if upper? `(1+ i) `(- ndiags i)) :for ,of-a :of-type index-type := ,dof-a :then (,(if upper? '- '+) ,of-a (:mark (aref ,strd-a 0))) :for ,of-b :of-type index-type := ,dof-b :then (,(if upper? '- '+) ,of-b (:mark (aref ,strd-b 0))) - ,@(unless diag? `(:unless (= j 0))) - :do (progn - ,(if diag? - `(if (= - (t/store-set ,sym (t/store-ref ,sym ,sto-a ,of-a) ,sto-b ,of-b)))))))))) + :do (t/store-set ,sym (t/store-ref ,sym ,sto-a ,of-a) ,sto-b ,of-b)))))) ,b)))) - +;; +(deft/generic (t/copy-diagonal! #'subtypep) sym (a b &optional num?)) +(deft/method t/copy-diagonal! (sym standard-tensor) (a b &optional (num? nil)) + (using-gensyms (decl (a b)) + (with-gensyms (sto-a sto-b of-a of-b) + `(let* (,@decl + ,@(unless num? `((,sto-a (store ,a)))) + (,sto-b (store ,b))) + (declare (type ,sym ,@(unless num? `(,a)) ,b) + (type ,(store-type sym) ,@(unless num? `(,sto-a)) ,sto-b) + ,@(when num? `((type ,(field-type sym) ,a)))) + (with-marking + (very-quickly + (:mark* ((ndiags (lvec-min (dimensions ,b)))) + (loop :for i :from 0 :below ndiags + ,@(unless num? `(:for ,of-a :of-type index-type := (head ,a) :then (+ ,of-a (:mark (lvec-foldr #'+ (strides ,a)) :type index-type)))) + :for ,of-b :of-type index-type := (head ,b) :then (+ ,of-b (:mark (lvec-foldr #'+ (strides ,b)) :type index-type)) + :do (t/store-set ,sym ,@(if num? `(,a) `((t/store-ref ,sym ,sto-a ,of-a))) ,sto-b ,of-b))))) + ,b)))) ;; (defmethod copy! :before ((x standard-tensor) (y standard-tensor)) (assert (very-quickly (lvec-eq (the index-store-vector (dimensions x)) (the index-store-vector (dimensions y)) #'=)) nil ----------------------------------------------------------------------- Summary of changes: README | 279 ++++++++++++++++++++++++++----------------------- src/lapack/lu.lisp | 4 +- src/level-1/copy.lisp | 30 ++++-- 3 files changed, 172 insertions(+), 141 deletions(-) hooks/post-receive -- matlisp |
From: Akshay S. <ak...@us...> - 2013-09-24 00:09:18
|
This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "matlisp". The branch, tensor has been updated via 6f9bed41c2556366ed4f8bc79516e8c3c3a19ee0 (commit) from 5304b7204035eab0b7ac2664a6e1949a0689e741 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 6f9bed41c2556366ed4f8bc79516e8c3c3a19ee0 Author: Akshay Srinivasan <aks...@gm...> Date: Mon Sep 23 17:09:04 2013 -0700 Updated README, removed unfinshed code in lu diff --git a/README b/README index 3bec6c9..1afd453 100644 --- a/README +++ b/README @@ -1,21 +1,151 @@ # -*- Mode: org -*- - -MatLisp - a base for scientific computation in Lisp. +MatLisp is intended to be a base for scientific computation in Lisp. This is the development branch of Matlisp. +MatLisp is made from a mixture of CLOS, lots of macros and the disdain +for other programming languages :) The old version aimed mostly towards handling +matrices, and was more of a Lispy-interface for Fortran. This version can handle +general dense tensors, and is in part inspired by the architecture of femlisp.matlisp. +It can also generate very fast generic BLAS routines lazily at run-time and reduce +the overhead of FFI calls. + +* Why MatLisp(and Lisp)? + Lisp is a very hacker friendly language - the difference between + source and binary is almost non-existent. When you use Matlisp we + are being selfish in that we hope that when you do use Matlisp, you + hack matlisp and contribute changes back. + + With Lisp, you have at your disposable the complete Lisp language and CLOS, + and the fabled macros. This allows you to write clean, object-oriented code + that can utilize the LAPACK matrix routines. Thus, you can think about your + problem in the natural way instead of trying to force-fit your problem in + matrices, like some other packages do. + +** How does this compare to Matlab, SciPy, Octave, R etc? + These packages are much in a much more mature stage than Matlisp; we + also lack most of the features in these packages. However, Matlisp was + built with the hope that expressibility and performance don't necessarily + have to mutually exclusive; in that we're not alone: Lush, and + Julia both have similar goals. + + In all the popular scientific packages, one sacrifices performance for + generally having the language manage your datastructures (ahem, matrices). + This has been changing of course with Cython, Numba, and Matlab's very own + JIT; nevertheless, there are lots of constraints on what can be expressed + efficiently, and succinctly in these language. In nearly all of them you'd + have to write lots of boiler plate code in C to get something to run reasonably + quickly; of course Matrices are passed straight in BLAS/LAPACK so "vectorised" + code becomes second nature. Few if any languages have anything close to macros. + So matlisp, in essence is for the kind of people who use (and love) lisp. + + With all things equal(which they are not), Matlisp(+SBCL) beats or is about as + fast as any of these packages; if you really want to squeeze every bit of + computational power, you can in most cases optimize loops, so that they're + as fast as C. However, there are limitations to what you can do vs C, because + of the Lisp implementation overheads (things like SSE, blocked computation). + + CCL does not unbox floats for multiplication, so your performance will suffer + if you choose CCL. + +* How to Install + Matlisp uses CFFI for callng foreign functions. That said, the FFI + capabilities of different lisps are quite different. So if your Lisp + implementation supports callbacks and calling plain C functions and + maps float simple-arrays into C-type arrays in memory, it shouldn't + be too hard to get it working (if it doesn't work already). We've tested + Matlisp on CCL and SBCL. The build system is cranky with all the new changes. + + + Linux/Unix Installation: + ======================== + + One of the design goals of Matlisp was to ensure the consistency of + installation. Matlisp is currently distributed as source code and the + user must do a compilation. A great deal of effort was put into a + configure script that determines machine parameters, system libraries + and without bothering the user. + + The installation follows in a few easy steps: + + Download and install quicklisp http://www.quicklisp.org/beta/; make sure the quicklisp directory is "~/quicklisp/" + (This step makes sure that CFFI is available, more advanced users can skip this and install + CFFI and make it visible to ASDF). + + Download the Matlisp: + > git clone git://git.code.sf.net/p/matlisp/git matlisp-git + > cd matlisp-git + > git checkout tensor + + Install all the configuration scripts the first time. + > autoreconf --install + + Create a build directory. (You can use any name you like). + > mkdir build + > cd build + + Use the following if you want to build and use the reference blas/lapack implementation. + > ../configure --libdir=$PWD/lib --enable-static=no --enable-<lisp> --with-lisp-exec=<exec> + (<lisp> \in {sbcl, ccl, cmucl, acl}) + You don't need to build matlisp in order to use a different lisp implementations (yes, this + is quite redundant). + + If you already have a optimized version of BLAS/LAPACK: + > ../configure --libdir=$PWD/lib --enable-static=no --enable-<lisp> --with-lisp-exec=<exec> --with-external-blas-lapack=<path> + On linux, <path> is usually /usr/lib/ + On Mac OSX, you can use vecLib by setting <path> to /System/Library/Frameworks/Accelerate.framework/Frameworks/vecLib.framework/Versions/A/ + + If configure does not select the desired Fortran compiler and + compiler flags, you can specify them like this: + ../configure F77=f77 FFLAGS='-g -O -KPIC' ... + + Avanti! + > make + This should land you in a lisp shell at the end. + + To use matlisp after building just call + CL-USER> (load "<matlisp-path>/build/start.lisp") + CL-USER> (in-package :matlisp) + +* Example usage + More documentation will be added as things reach a nicer stage of development. + + ;;Creation + MATLISP> (copy! (randn '(2 2)) (zeros '(2 2) 'complex-tensor)) + #<COMPLEX-TENSOR #(2 2) + -1.5330 -1.67578E-2 + -.62578 -.63278 + > + + ;;gemv + MATLISP> (let ((a (randn '(2 2))) + (b (randn 2))) + (gemv 1 a b nil nil)) + #<REAL-TENSOR #(2) + 1.1885 0.95746 + > + + ;;Tensor contraction + MATLISP> (let ((H (randn '(2 2 2))) + (b (randn 2)) + (c (randn 2)) + (f (zeros 2))) + (einstein-sum real-tensor (i j k) (ref f i) (* (ref H i j k) (ref b j) (ref c k)))) + #<REAL-TENSOR #(2) + 0.62586 -1.1128 + > + * Progress Tracker ** What works ? - * Basic {real, complex} tensor structure in place. - * Added a specialisation agnostic macros {copy, scal} which generate - functions by getting special method producing macros - produced - by another macro {tensor-store-defs}. - * copy, scal, dot, swap, axpy work - * tensor-{real, imag}part(~) work - * sub-tensor~ works - * print methods work + * Generic template structure. + * Double real, complex tensor structures in place. + * Templates for optimized BLAS methods in Lisp. + * Automatic switching between Lisp routines and BLAS. + * Inplace slicing, real - imag views for complex tensors. + * copy, scal, dot, swap, axpy, gemv, gemm, getrf/getrs (lu), geev(eig), potrf/potrs(chol), geqr * permutation class, sorting, conversion between action and cycle representations. * mod-loop works, can produce very quick multi-index loops. + * einstein macro works, can produce optimized loops. ** TODO : What remains ? (Help!) *** Functionality @@ -23,17 +153,19 @@ This is the development branch of Matlisp. * Add negative stride support, ala Python. * Tensor contraction: Hard to do very quickly. Might have to copy stuff into a contiguous array; like Femlisp. - * BLAS level-2 and level-3: most importantly Matrix multiplication. - * LAPACK: solving Linear equations, Eigenvalue decomposition. + * LAPACK: Add interfaces to remaining functions. * DFFTPACK: computing FFTs * QUADPACK: Move from f2cl-ed version to the Fortran one. * MINPACK: Move from f2cl-ed version to the Fortran one. * ODEPACK: Add abstraction for DLSODE, and DLSODAR may others too. - * Add a Lisp generic wrapper for every BLAS func {low priority}. *** Syntactic sugar * Add array slicing macros * Might have to add something to make it compatible with old Matlisp. + +*** Gnuplot interface + * Make gnuplot interface more usable. + *** Python-bridge (C)Python has far too many things, that we cannot even begin to hope to replicate. Burgled-batteries has a lot of things which could be useful in talking to CPython. @@ -46,7 +178,7 @@ This is the development branch of Matlisp. although changes are not strictly local. *** Support linking to libraries ? - Might have to parse header files with cffi-grovel. + Parse header files with cffi-grovel. *** Documentation, tests * Write documentation. @@ -57,120 +189,5 @@ This is the development branch of Matlisp. *** Symbolics, AD, more fancy stuff {wishlist} * Use things like macrofy to work with Maxima * Provide seamless AD, Symbolic differentiation and numerical function calls, ala scmutils. - - -* What is MatLisp? - - MatLisp is a set of CLOS classes for handling multidimensional - arrays with real-valued or complex-valued elements. - - However, a implementation of the matrix operations entirely in Lisp - could have been done, but such an approach completely ignores the - excellent packages available for matrices. In particular, LAPACK is - used to handle the matrix operations. - - Thus, MatLisp supplies a set of wrapper classes and functions around - the core LAPACK routines. - - -* Why MatLisp? - - Lisp is a very hacker friendly language - the difference between - source and binary is almost non-existent. When you use Matlisp we - are being selfish in that we hope that when you do use Matlisp, you - hack matlisp and contribute changes back. - - While MatLisp essentially supplies a wrapper around the BLAS/LAPACK - routines, it is more than just that. You have at your disposable the - complete Lisp language and CLOS, and the fabled macros. - - This allows you to write clean, object-oriented code that can utilize - the LAPACK matrix routines. Thus, you can think about your problem in - the natural way instead of trying to force-fit your problem in - matrices, like some other packages do. - -* What about Matlab, SciPy, Octave, etc? - - While all of these are good at what they do, they all have a - fundamental limitation: Everything is a matrix. You have no - alternative. Either you make your problem fit into a matrix, or you - can't use these languages. The exception is Rlab, which does have - simple lists in addition to matrices. However, that's as far as it goes. - - MatLisp frees you from this limitation---you have at your disposal, - the complete functionality of Common Lisp, including structures, hash - tables, lists, arrays, and the Common Lisp Object System (CLOS). - MatLisp adds to this richness by giving you a matrix fast class based - on the well-known and well-tested LAPACK library. - - Thus, you can think about your problem in the most natura - l way, without having to force everything into a matrix. If the natural way, - you can then use a matrix, and achieve performance close to Matlab and - the other languages. - - -* How to Install - - See the file INSTALL. - -* Usage - - This is very short. Here is a list of available routines - - make-float-matrix - create a float matrix - (make-float-matrix n m) - creates an n x m matrix initialize to zero. - (make-float-matrix #2a(...)) - creates a matrix with the same dimensions as the array and - initializes the matrix with those elements. - (make-float-matrix '((...) (...) ...)) - creats a matrix of the appropriate dimensions and initializes - it to the elements in the list. - - make-complex-matrix - create a complex matrix - (make-complex-matrix n m) - creates an n x m matrix initialize to zero. - (make-complex-matrix #2a(...)) - creates a matrix with the same dimensions as the array and - initializes the matrix with those elements. - (make-complex-matrix '((...) (...) ...)) - creats a matrix of the appropriate dimensions and initializes - it to the elements in the list. - - - [] - create a float or complex matrix - [1 2 ; 3 4] - creates a 2x2 matrix - [[1 3]' [2 4]'] - creates the same 2x2 matrix - [[1 2] ; [3 4]] - creates the same 2x2 matrix - - matrix-ref - access the elements of the matrix. Indices are 0-based. - (matrix-ref mat r) - access the array as if it were really 1-dimensional. Matrix - is stored in column-major order. - (matrix-ref mat r c) - access element r,c - (matrix-ref mat ridx) - if ridx is a matrix or a sequence, ridx is used as the indices - to extract the corresponding elements from the matrix. - - m+ - add two matrices - - m- - subtract two matrices. If only one matrix is given, return - the negative of the matrix. - - m* - multiply two matrices - - m/ - divide two matrices. (m/ a b) means the same as inv(B)*A. - (m/ a) is the same as inv(A). - + * Symbolic stuff tends to fit in easily with the lisp-based BLAS routines. + Port code from src/classes/symbolic-tensor.lisp diff --git a/src/lapack/lu.lisp b/src/lapack/lu.lisp index 9a9be99..fcd9d92 100644 --- a/src/lapack/lu.lisp +++ b/src/lapack/lu.lisp @@ -136,8 +136,8 @@ By default WITH-L,WITH-U,WITH-P. ")) -(defmethod lu ((a standard-tensor) &optional split-lu?) - (let ((lu (getrf! (copy a)) +;; (defmethod lu ((a standard-tensor) &optional split-lu?) +;; (let ((lu (getrf! (copy a)) #+nil (defmacro make-lu (tensor-class) ----------------------------------------------------------------------- Summary of changes: README | 279 +++++++++++++++++++++++++++------------------------ src/lapack/lu.lisp | 4 +- 2 files changed, 150 insertions(+), 133 deletions(-) hooks/post-receive -- matlisp |
From: Akshay S. <ak...@us...> - 2013-09-23 22:53:16
|
This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "matlisp". The branch, tensor has been updated via 5304b7204035eab0b7ac2664a6e1949a0689e741 (commit) via d112fcce019bbf7c536a4047927cfa248bff6239 (commit) via 54c32278dd5b119ca1157b022ebe1a1b0f945f8e (commit) via 06961b98935b57db5dd4d9b56bdd93c647ba6484 (commit) via 22f5a0bcf4a70d769e8448e05840fc9ce8fe7988 (commit) via e2cf244082f3b9993eb6d9e4f6051349f80ccbbd (commit) via cd98eb7ed25c777623ccbacac627bb4968574536 (commit) via 2247ca7cc973977e061ee894efee10faec823f1d (commit) via e41ab636a047d01b438e86d24ad4b5169d0edfe2 (commit) from f8b87a620796e228cadb86996b85f4298409ed75 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- ----------------------------------------------------------------------- Summary of changes: lib-src/gnuplot/gnuplot.lisp | 22 ++- packages.lisp | 5 +- src/base/einstein.lisp | 26 +-- src/foreign-core/lapack.lisp | 4 +- src/lapack/eig.lisp | 23 +-- src/lapack/geev.lisp | 524 ------------------------------------------ src/lapack/geqr.lisp | 154 +++++-------- src/lapack/lu.lisp | 3 + src/level-1/copy.lisp | 30 +++ src/level-2/gemv.lisp | 2 +- src/level-3/gemm.lisp | 10 +- src/special/map.lisp | 4 + src/utilities/functions.lisp | 24 ++ src/utilities/macros.lisp | 55 +++++- tests/loopy-tests.lisp | 21 +- 15 files changed, 224 insertions(+), 683 deletions(-) delete mode 100644 src/lapack/geev.lisp hooks/post-receive -- matlisp |
From: Akshay S. <ak...@us...> - 2013-09-23 22:50:15
|
This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "matlisp". The branch, classy has been updated via 5304b7204035eab0b7ac2664a6e1949a0689e741 (commit) via d112fcce019bbf7c536a4047927cfa248bff6239 (commit) via 54c32278dd5b119ca1157b022ebe1a1b0f945f8e (commit) via 06961b98935b57db5dd4d9b56bdd93c647ba6484 (commit) via 22f5a0bcf4a70d769e8448e05840fc9ce8fe7988 (commit) via e2cf244082f3b9993eb6d9e4f6051349f80ccbbd (commit) via cd98eb7ed25c777623ccbacac627bb4968574536 (commit) via 2247ca7cc973977e061ee894efee10faec823f1d (commit) via e41ab636a047d01b438e86d24ad4b5169d0edfe2 (commit) from f8b87a620796e228cadb86996b85f4298409ed75 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 5304b7204035eab0b7ac2664a6e1949a0689e741 Author: Akshay Srinivasan <aks...@gm...> Date: Mon Sep 23 15:41:49 2013 -0700 o Fixed bug in triangle template. diff --git a/src/level-1/copy.lisp b/src/level-1/copy.lisp index 3bcb166..3399780 100644 --- a/src/level-1/copy.lisp +++ b/src/level-1/copy.lisp @@ -145,7 +145,7 @@ :do (progn ,(if diag? `(if (= - (t/store-set ,sym (t/store-ref ,sym ,sto-a ,of-a) ,sto-b ,of-b)))))) + (t/store-set ,sym (t/store-ref ,sym ,sto-a ,of-a) ,sto-b ,of-b)))))))))) ,b)))) ;; commit d112fcce019bbf7c536a4047927cfa248bff6239 Author: Akshay Srinivasan <aks...@gm...> Date: Thu Sep 19 22:39:13 2013 -0700 Added splot to gnuplot, added triangle-copy template. diff --git a/lib-src/gnuplot/gnuplot.lisp b/lib-src/gnuplot/gnuplot.lisp index 59ba49b..d55f9da 100644 --- a/lib-src/gnuplot/gnuplot.lisp +++ b/lib-src/gnuplot/gnuplot.lisp @@ -1,11 +1,12 @@ (in-package :matlisp) (defvar *current-gnuplot-process* nil) -(defun open-gnuplot-stream (&optional (gnuplot-binary - #+darwin - (pathname "/opt/local/bin/gnuplot") - #+linux - (pathname "/usr/bin/gnuplot"))) +(defun open-gnuplot-stream (&key (gnuplot-binary + #+darwin + (pathname "/opt/local/bin/gnuplot") + #+linux + (pathname "/usr/bin/gnuplot")) + (terminal "wxt")) (setf *current-gnuplot-process* (#+:sbcl sb-ext:run-program #+:ccl @@ -13,7 +14,8 @@ gnuplot-binary nil :input :stream :wait nil :output t)) (gnuplot-send " set datafile fortran -") +set term ~a +" terminal) *current-gnuplot-process*) (defun close-gnuplot-stream () @@ -37,7 +39,7 @@ set datafile fortran (multiple-value-bind (b2 b1) (floor a 256) (list b2 b1 b0)))) -(defun plot2d (data &key (lines t) (color nil)) +(defun plot (data &key (lines t) (color nil)) (let ((fname "/tmp/matlisp-gnuplot.out")) (with-open-file (s fname :direction :output :if-exists :supersede :if-does-not-exist :create) (loop :for i :from 0 :below (loop :for x :in data :minimizing (size x)) @@ -45,7 +47,7 @@ set datafile fortran (let ((col (if (listp color) color (let ((lst (list color))) (setf (cdr lst) lst) - lst)))) + lst)))) (let ((cmd (apply #'string+ (cons "plot " (loop :for x :in (cdr data) :for i := 2 :then (1+ i) :for clist := col :then (cdr clist) @@ -60,6 +62,14 @@ set datafile fortran (setf (aref cmd (- (length cmd) 2)) #\; (aref cmd (- (length cmd) 1)) #\Newline) (gnuplot-send cmd))))) + +(defun splot (data) + (let ((fname "/tmp/matlisp-gnuplot.out")) + (with-open-file (s fname :direction :output :if-exists :supersede :if-does-not-exist :create) + (loop :for i :from 0 :below (loop :for x :in data :minimizing (size x)) + :do (loop :for x :in data :do (format s "~a " (coerce (ref x i) 'single-float)) :finally (format s "~%")))) + (gnuplot-send (string+ "splot \'" fname "\' +")))) ;; (defclass gnuplot-plot-info () ;; ((title diff --git a/packages.lisp b/packages.lisp index ad00eb4..b0aa7ca 100644 --- a/packages.lisp +++ b/packages.lisp @@ -86,7 +86,7 @@ #:compile-and-eval #:getcons #:mapcons ;;Macros - #:when-let #:if-let #:if-ret #:with-gensyms #:let-rec #:using-gensyms + #:when-let #:if-let #:if-ret #:with-gensyms #:let-rec #:using-gensyms #:with-marking #:mlet* #:make-array-allocator #:let-typed #:let*-typed #:nconsc #:define-constant #:macrofy #:looped-mapcar #:defun-compiler-macro diff --git a/src/lapack/geqr.lisp b/src/lapack/geqr.lisp index 57c56d5..2c52eba 100644 --- a/src/lapack/geqr.lisp +++ b/src/lapack/geqr.lisp @@ -47,42 +47,6 @@ ") (:method :before ((a standard-tensor)) (assert (tensor-matrixp a) nil 'tensor-dimension-mismatch))) - -(defmacro loop-lt ((dims-e &rest mats) &rest body) - (let ((syms (mapcar #'(lambda (x) - (let ((mat-sym (gensym))) - `((,mat-sym ,(cadr x)) - (,(gensym "strd") (strides ,mat-sym)) - (,(car x) (head x))))) - mats))) - (with-gensyms (i j dims) - `(let* (,@(apply #'append syms) - (,dims ,dims-e)) - (with-marking - (loop :for ,j :from 0 :below (mark (aref ,dims 1)) - :do (progn - ,@(mapcar #'(lambda (x) `(incf ,(car (third x)) (mark (aref ,(car (second x)) 1))))) - (loop :repeat :from 0 :below (mark (aref ,dims 0)) - :do (progn - ,@body)))))))) - -(deft/generic t/copy-upper-triangle (sym #'subtypep) (a b) - (using-gensyms (decl (a b)) - (with-gensyms (sto-a sto-b strd-a strd-b) - `(let (,@decl - (,sto-a (store ,a)) - (,strd-a (strides ,a)) - (,sto-b (store ,b)) - (,strd-b (strides ,b))) - (declare (type ,sym ,a ,b) - (type ,(store-type sym) ,sto-a ,sto-b) - (type index-store-vector ,strd-a ,strd-b)) - (very-quickly - (loop :repeat (nrows ,a) - :for rof-a :of-type index-type := (head a) :then (+ rof-a (aref strd-a 0)) - :for rof-a :of-type index-type := (head a) :then (+ rof-a (aref strd-a 0)) - :do (loop :repeat (ncols b) - :do (t/store-set ,sym (t/store-ref ,sym sto-a ..) sto-b ..)))))))))) (defmethod geqr! ((a standard-tensor)) (let ((cla (class-name (class-of A)))) diff --git a/src/lapack/lu.lisp b/src/lapack/lu.lisp index 4da2596..9a9be99 100644 --- a/src/lapack/lu.lisp +++ b/src/lapack/lu.lisp @@ -136,6 +136,9 @@ By default WITH-L,WITH-U,WITH-P. ")) +(defmethod lu ((a standard-tensor) &optional split-lu?) + (let ((lu (getrf! (copy a)) + #+nil (defmacro make-lu (tensor-class) (let* ((opt (if-ret (get-tensor-class-optimization-hashtable tensor-class) diff --git a/src/level-1/copy.lisp b/src/level-1/copy.lisp index f7432f7..3bcb166 100644 --- a/src/level-1/copy.lisp +++ b/src/level-1/copy.lisp @@ -117,6 +117,36 @@ (,of-y (strides ,y) (head ,y))) :do (t/store-set ,cly ,cx ,sto-y ,of-y))) ,y)))) +;; +;;This macro is used for interfacing with lapack +;;Only to be used with matrices! +(deft/generic (t/copy-triangle! #'subtypep) sym (a b &optional upper? diag?)) +(deft/method t/copy-triangle! (sym standard-tensor) (a b &optional (upper? nil) (diag? t)) + (using-gensyms (decl (a b)) + (with-gensyms (sto-a sto-b strd-a strd-b dof-a dof-b of-a of-b) + `(let* (,@decl + (,sto-a (store ,a)) + (,strd-a (strides ,a)) + (,sto-b (store ,b)) + (,strd-b (strides ,b))) + (declare (type ,sym ,a ,b) + (type ,(store-type sym) ,sto-a ,sto-b) + (type index-store-vector ,strd-a ,strd-b)) + (with-marking + (very-quickly + (:mark* ((ndiags (min (nrows ,a) (ncols ,a)))) + (loop :for i :from 0 :below ndiags + :for ,dof-a :of-type index-type := (head ,a) :then (+ ,dof-a (:mark (lvec-foldr #'+ ,strd-a) :type index-type)) + :for ,dof-b :of-type index-type := (head ,b) :then (+ ,dof-b (:mark (lvec-foldr #'+ ,strd-b) :type index-type)) + :do (loop :for j :from 0 :below ,(if upper? `(1+ i) `(- ndiags i)) + :for ,of-a :of-type index-type := ,dof-a :then (,(if upper? '- '+) ,of-a (:mark (aref ,strd-a 0))) + :for ,of-b :of-type index-type := ,dof-b :then (,(if upper? '- '+) ,of-b (:mark (aref ,strd-b 0))) + ,@(unless diag? `(:unless (= j 0))) + :do (progn + ,(if diag? + `(if (= + (t/store-set ,sym (t/store-ref ,sym ,sto-a ,of-a) ,sto-b ,of-b)))))) + ,b)))) ;; (defmethod copy! :before ((x standard-tensor) (y standard-tensor)) diff --git a/src/special/map.lisp b/src/special/map.lisp index 98b8443..9dcb66b 100644 --- a/src/special/map.lisp +++ b/src/special/map.lisp @@ -39,6 +39,10 @@ :do (t/store-set ,cly (funcall func (t/store-ref ,clx sto-x of-x)) sto-y of-y)))) y))) (mapsor! func x y)) + +(definline mapsor (func x) + (let ((ret (zeros (dimensions x) (class-of x)))) + (mapsor! func x ret))) ;; (defun mapslice (func x &optional (axis 0)) diff --git a/src/utilities/macros.lisp b/src/utilities/macros.lisp index 199478c..c105360 100644 --- a/src/utilities/macros.lisp +++ b/src/utilities/macros.lisp @@ -40,7 +40,7 @@ Example: (types nil) (code (mapcons #'(lambda (mrk) (ecase (car mrk) - (mark* + (:mark* `(symbol-macrolet (,@(mapcar #'(lambda (decl) (destructuring-bind (ref code &key type) decl (let ((rsym (gensym (symbol-name ref)))) (push `(,rsym ,code) decls) @@ -49,14 +49,14 @@ Example: `(,ref ,rsym)))) (cadr mrk))) ,@(cddr mrk))) - (mark + (:mark (destructuring-bind (code &key type) (cdr mrk) (let ((rsym (gensym))) (push `(,rsym ,code) decls) (when type (push `(type ,type ,rsym) types)) rsym))))) - body '(mark* mark)))) + body '(:mark* :mark)))) `(let* (,@decls) ,@(when types `((declare ,@types))) ,@code))) @@ -531,9 +531,9 @@ Example: (defmacro slowly (&body forms) " Macro which encloses @arg{forms} inside - (declare (optimize (speed 1))) + (declare (optimize (speed 1) (debug 3))) " - `(with-optimization (:speed 1) + `(with-optimization (:speed 1 :debug 3) ,@forms)) ) commit 54c32278dd5b119ca1157b022ebe1a1b0f945f8e Author: Akshay Srinivasan <aks...@gm...> Date: Tue Sep 17 15:37:01 2013 -0700 Fixed a bug in gemm. Moved useful stuff from einstein.lisp into utilities. Added "with-marking" macro for nicer local/global semantics. diff --git a/packages.lisp b/packages.lisp index f3d665d..ad00eb4 100644 --- a/packages.lisp +++ b/packages.lisp @@ -73,7 +73,7 @@ #:vectorify #:copy-n #:ensure-args #:repsym #:findsym #:find-tag #:zip #:zip-eq #:zipsym - #:list-eq #:setadd #:setrem + #:list-eq #:setadd #:setrem #:set-eq #:cut-cons-chain! #:slot-values #:remmeth #:recursive-append #:unquote-args #:flatten @@ -84,6 +84,7 @@ #:lvec-map-foldl! #:lvec-map-foldr! #:lvec->list #:lvec->list! #:compile-and-eval + #:getcons #:mapcons ;;Macros #:when-let #:if-let #:if-ret #:with-gensyms #:let-rec #:using-gensyms #:mlet* #:make-array-allocator #:let-typed #:let*-typed diff --git a/src/base/einstein.lisp b/src/base/einstein.lisp index 264aa92..cf29c9b 100644 --- a/src/base/einstein.lisp +++ b/src/base/einstein.lisp @@ -1,23 +1,9 @@ (in-package :matlisp) -(defun get-cons (lst sym) - (if (atom lst) nil - (if (eq (car lst) sym) - (list lst) - (append (get-cons (car lst) sym) (get-cons (cdr lst) sym))))) - (defun has-sym (lst sym) (if (atom lst) (eql lst sym) (or (has-sym (car lst) sym) (has-sym (cdr lst) sym)))) -(defun mapcons (func lst keys) - (if (atom lst) lst - (let ((tlst (if (member (car lst) keys) - (funcall func lst) - lst))) - (if (atom tlst) tlst - (mapcar #'(lambda (x) (mapcons func x keys)) tlst))))) - ;;Only works for distinct objects (defun generate-permutations (lst) (if (null (cdr lst)) (list lst) @@ -26,18 +12,8 @@ (mapcar #'(lambda (y) (cons x y)) (generate-permutations pop-x)))) lst)))) -(defun set-eq (a b &key (test #'eql)) - (and (loop :for ele :in a - :do (unless (member ele b :test test) - (return nil)) - :finally (return t)) - (loop :for ele :in b - :do (unless (member ele a :test test) - (return nil)) - :finally (return t)))) - (defun parse-loopx (type place clause) - (let* ((refs (let ((tmp (get-cons (list place clause) 'ref)) + (let* ((refs (let ((tmp (getcons (list place clause) 'ref)) (ret nil)) (loop :for ele :in tmp :do (setf ret (setadd ret ele #'equal))) diff --git a/src/lapack/geqr.lisp b/src/lapack/geqr.lisp index 0971de8..57c56d5 100644 --- a/src/lapack/geqr.lisp +++ b/src/lapack/geqr.lisp @@ -47,45 +47,6 @@ ") (:method :before ((a standard-tensor)) (assert (tensor-matrixp a) nil 'tensor-dimension-mismatch))) - - -(defmacro with-marking (&rest body) - (let* ((decls nil) - (types nil) - (code (mapcons #'(lambda (mrk) - (ecase (car mrk) - (mark* - `(symbol-macrolet (,@(mapcar #'(lambda (decl) (destructuring-bind (ref code &key type) decl - (let ((rsym (gensym (symbol-name ref)))) - (push `(,rsym ,code) decls) - (when type - (push `(type ,type ,rsym) types)) - `(,ref ,rsym)))) - (cadr mrk))) - ,@(cddr mrk))) - (mark - (destructuring-bind (code &key type) (cdr mrk) - (let ((rsym (gensym))) - (push `(,rsym ,code) decls) - (when type - (push `(type ,type ,rsym) types)) - rsym))))) - body '(mark* mark)))) - `(let* (,@decls) - ,@(when types `((declare ,@types))) - ,@code))) - -(with-marking - (loop :for i := 0 :then (1+ i) - :do (mark* ((xi (* 10 2) :type index-type) - (sum 0 :type index-type)) - (incf sum (mark (* 10 2))) - (if (= i 10) - (return sum))))) - -(loop-upper-triangle ((dimensions x) - (of-a a) - (of-b b))) (defmacro loop-lt ((dims-e &rest mats) &rest body) (let ((syms (mapcar #'(lambda (x) diff --git a/src/level-2/gemv.lisp b/src/level-2/gemv.lisp index 3dfb285..75ba8a2 100644 --- a/src/level-2/gemv.lisp +++ b/src/level-2/gemv.lisp @@ -160,5 +160,5 @@ (defmethod gemv (alpha (A standard-tensor) (x standard-tensor) (beta (eql nil)) (y (eql nil)) &optional (job :n)) - (let ((ret (zeros (nrows A) (class-of A)))) + (let ((ret (zeros (ecase job (:n (nrows A)) (:t (ncols A))) (class-of A)))) (gemv! alpha A x 1 ret job))) diff --git a/src/level-3/gemm.lisp b/src/level-3/gemm.lisp index b2cec50..7c824c0 100644 --- a/src/level-3/gemm.lisp +++ b/src/level-3/gemm.lisp @@ -140,7 +140,7 @@ (with-columnification (,cla ((a joba) (b jobb)) (c)) (multiple-value-bind (lda opa) (blas-matrix-compatiblep a joba) (multiple-value-bind (ldb opb) (blas-matrix-compatiblep b jobb) - (t/blas-gemm! ,cla alpha A lda B ldb beta C ldb opa opb)))))) + (t/blas-gemm! ,cla alpha A lda B ldb beta C (or (blas-matrix-compatiblep c #\N) 0) opa opb)))))) `(t/gemm! ,cla alpha A B beta C joba jobb)))) C)) (gemm! alpha A B beta C job)) @@ -175,3 +175,11 @@ (defmethod gemm (alpha (A standard-tensor) (B standard-tensor) beta (C standard-tensor) &optional (job :nn)) (gemm! alpha A B beta (copy C) job)) + +(defmethod gemm (alpha (A standard-tensor) (B standard-tensor) + (beta (eql nil)) (C (eql nil)) &optional (job :nn)) + (let ((ret (destructuring-bind (job-a job-b) (split-job job) + (zeros (list (ecase job-a (#\N (nrows A)) ((#\C #\T) (ncols A))) + (ecase job-b (#\N (ncols B)) ((#\C #\T) (nrows B)))) + (class-of A))))) + (gemm! alpha A B 1 ret job))) diff --git a/src/utilities/functions.lisp b/src/utilities/functions.lisp index f790208..6494995 100644 --- a/src/utilities/functions.lisp +++ b/src/utilities/functions.lisp @@ -56,6 +56,16 @@ (cdr lst) (cons (car lst) (setrem (cdr lst) a test))))) +(defun set-eq (a b &key (test #'eql)) + (and (loop :for ele :in a + :do (unless (member ele b :test test) + (return nil)) + :finally (return t)) + (loop :for ele :in b + :do (unless (member ele a :test test) + (return nil)) + :finally (return t)))) + (declaim (inline copy-n)) (defun copy-n (vec lst n) (declare (type vector vec) @@ -66,6 +76,20 @@ :do (setf (car vlst) (aref vec i))) lst) +(defun getcons (lst sym) + (if (atom lst) nil + (if (eq (car lst) sym) + (list lst) + (append (getcons (car lst) sym) (getcons (cdr lst) sym))))) + +(defun mapcons (func lst keys) + (if (atom lst) lst + (let ((tlst (if (member (car lst) keys) + (funcall func lst) + lst))) + (if (atom tlst) tlst + (mapcar #'(lambda (x) (mapcons func x keys)) tlst))))) + (defun find-tag (lst tag) (let ((car (car lst))) (if (atom car) diff --git a/src/utilities/macros.lisp b/src/utilities/macros.lisp index f19868f..199478c 100644 --- a/src/utilities/macros.lisp +++ b/src/utilities/macros.lisp @@ -10,6 +10,57 @@ `(defconstant ,name (if (boundp ',name) (symbol-value ',name) ,value) ,@(when doc (list doc)))) +(defmacro with-marking (&rest body) + " + This macro basically declares local-variables globally, + while keeping semantics and scope local. + +Example: + > (macroexpand-1 + `(with-marking + (loop :for i := 0 :then (1+ i) + :do (mark* ((xi (* 10 2) :type index-type) + (sum 0 :type index-type)) + (incf sum (mark (* 10 2))) + (if (= i 10) + (return sum)))))) + + (LET* ((#:G1083 (* 10 2)) (#:SUM1082 0) (#:XI1081 (* 10 2))) + (DECLARE (TYPE INDEX-TYPE #:SUM1082) + (TYPE INDEX-TYPE #:XI1081)) + (LOOP :FOR I := 0 :THEN (1+ I) + :DO (SYMBOL-MACROLET ((XI #:XI1081) (SUM #:SUM1082)) + (INCF SUM #:G1083) + (IF (= I 10) + (RETURN SUM))))) + T + > +" + (let* ((decls nil) + (types nil) + (code (mapcons #'(lambda (mrk) + (ecase (car mrk) + (mark* + `(symbol-macrolet (,@(mapcar #'(lambda (decl) (destructuring-bind (ref code &key type) decl + (let ((rsym (gensym (symbol-name ref)))) + (push `(,rsym ,code) decls) + (when type + (push `(type ,type ,rsym) types)) + `(,ref ,rsym)))) + (cadr mrk))) + ,@(cddr mrk))) + (mark + (destructuring-bind (code &key type) (cdr mrk) + (let ((rsym (gensym))) + (push `(,rsym ,code) decls) + (when type + (push `(type ,type ,rsym) types)) + rsym))))) + body '(mark* mark)))) + `(let* (,@decls) + ,@(when types `((declare ,@types))) + ,@code))) + (defmacro mlet* (vars &rest body) " This macro extends the syntax of let* to handle multiple values, it also handles commit 06961b98935b57db5dd4d9b56bdd93c647ba6484 Merge: 22f5a0b e2cf244 Author: Akshay Srinivasan <aks...@gm...> Date: Tue Sep 17 14:57:54 2013 -0700 Merge branch 'classy' of bicycle.cs.washington.edu:/homes/gws/akshays/git/matlisp into classy commit 22f5a0bcf4a70d769e8448e05840fc9ce8fe7988 Author: Akshay Srinivasan <aks...@gm...> Date: Tue Sep 17 14:56:33 2013 -0700 Added default gnuplot path for darwin. diff --git a/lib-src/gnuplot/gnuplot.lisp b/lib-src/gnuplot/gnuplot.lisp index f9b48dc..59ba49b 100644 --- a/lib-src/gnuplot/gnuplot.lisp +++ b/lib-src/gnuplot/gnuplot.lisp @@ -1,7 +1,11 @@ (in-package :matlisp) (defvar *current-gnuplot-process* nil) -(defun open-gnuplot-stream (&optional (gnuplot-binary (pathname "/usr/bin/gnuplot"))) +(defun open-gnuplot-stream (&optional (gnuplot-binary + #+darwin + (pathname "/opt/local/bin/gnuplot") + #+linux + (pathname "/usr/bin/gnuplot"))) (setf *current-gnuplot-process* (#+:sbcl sb-ext:run-program #+:ccl commit e2cf244082f3b9993eb6d9e4f6051349f80ccbbd Author: Akshay Srinivasan <aks...@gm...> Date: Tue Sep 17 14:33:14 2013 -0700 Saving state on QR. diff --git a/src/lapack/geqr.lisp b/src/lapack/geqr.lisp index e1af058..0971de8 100644 --- a/src/lapack/geqr.lisp +++ b/src/lapack/geqr.lisp @@ -48,21 +48,62 @@ (:method :before ((a standard-tensor)) (assert (tensor-matrixp a) nil 'tensor-dimension-mismatch))) -(defmacro loop-upper-triangle ((dims-e &rest mats) &rest body) + +(defmacro with-marking (&rest body) + (let* ((decls nil) + (types nil) + (code (mapcons #'(lambda (mrk) + (ecase (car mrk) + (mark* + `(symbol-macrolet (,@(mapcar #'(lambda (decl) (destructuring-bind (ref code &key type) decl + (let ((rsym (gensym (symbol-name ref)))) + (push `(,rsym ,code) decls) + (when type + (push `(type ,type ,rsym) types)) + `(,ref ,rsym)))) + (cadr mrk))) + ,@(cddr mrk))) + (mark + (destructuring-bind (code &key type) (cdr mrk) + (let ((rsym (gensym))) + (push `(,rsym ,code) decls) + (when type + (push `(type ,type ,rsym) types)) + rsym))))) + body '(mark* mark)))) + `(let* (,@decls) + ,@(when types `((declare ,@types))) + ,@code))) + +(with-marking + (loop :for i := 0 :then (1+ i) + :do (mark* ((xi (* 10 2) :type index-type) + (sum 0 :type index-type)) + (incf sum (mark (* 10 2))) + (if (= i 10) + (return sum))))) + +(loop-upper-triangle ((dimensions x) + (of-a a) + (of-b b))) + +(defmacro loop-lt ((dims-e &rest mats) &rest body) (let ((syms (mapcar #'(lambda (x) - (let ((mat-sym (gensyms))) - `((,mat-sym ,x) - (,(gensym "sto") (store ,mat-sym)) - (,(gensym "strides") (strides ,mat-sym)) - (,(gensym "dimensions") (dimensions ,mat-sym))))) + (let ((mat-sym (gensym))) + `((,mat-sym ,(cadr x)) + (,(gensym "strd") (strides ,mat-sym)) + (,(car x) (head x))))) mats))) (with-gensyms (i j dims) - `(let (,@(apply #'append syms) - (,dims ,dims-e)) - (loop :for ,i :from 0 :below (aref ,dims 0) - :do (loop :for ,j :from 0 :below (aref ,dims 1) - :do (progn - ,@body))))))) + `(let* (,@(apply #'append syms) + (,dims ,dims-e)) + (with-marking + (loop :for ,j :from 0 :below (mark (aref ,dims 1)) + :do (progn + ,@(mapcar #'(lambda (x) `(incf ,(car (third x)) (mark (aref ,(car (second x)) 1))))) + (loop :repeat :from 0 :below (mark (aref ,dims 0)) + :do (progn + ,@body)))))))) (deft/generic t/copy-upper-triangle (sym #'subtypep) (a b) (using-gensyms (decl (a b)) diff --git a/tests/loopy-tests.lisp b/tests/loopy-tests.lisp index cceb145..1f8a22e 100644 --- a/tests/loopy-tests.lisp +++ b/tests/loopy-tests.lisp @@ -1,15 +1,20 @@ (in-package :matlisp) -(defun tdcopy (n) - (let* ((t-a (make-real-tensor-dims n n n)) + +(defun tcopy (n &optional (rank 2)) + (let* ((dims (make-list rank :initial-element n)) + (t-a (zeros dims)) (st-a (store t-a)) - (t-b (make-real-tensor-dims n n n)) + (t-b (zeros dims)) (st-b (store t-b))) - (with-optimization (:speed 3 :safety 0 :space 0) - (mod-dotimes (idx (idxv n n)) - with (linear-sums - (of (idxv (* n n) n))) - do (dcopy n st-a 1 st-b 1 of of))))) + (declare (type (simple-array double-float (*)) st-a st-b)) + (time + (very-quickly + (mod-dotimes (idx (dimensions t-a)) + :with (linear-sums + (of-a (strides t-a) (head t-a)) + (of-b (strides t-b) (head t-b))) + :do (setf (aref st-b of-b) (aref st-a of-a))))))) (defun tcopy (n) (let* ((t-a (make-real-tensor-dims n n n)) commit cd98eb7ed25c777623ccbacac627bb4968574536 Author: Akshay Srinivasan <aks...@gm...> Date: Mon Sep 16 12:05:07 2013 -0700 Saving state. diff --git a/src/lapack/geqr.lisp b/src/lapack/geqr.lisp index 17c1818..e1af058 100644 --- a/src/lapack/geqr.lisp +++ b/src/lapack/geqr.lisp @@ -48,8 +48,22 @@ (:method :before ((a standard-tensor)) (assert (tensor-matrixp a) nil 'tensor-dimension-mismatch))) - -(defmacro loop-upper-triangle (cla +(defmacro loop-upper-triangle ((dims-e &rest mats) &rest body) + (let ((syms (mapcar #'(lambda (x) + (let ((mat-sym (gensyms))) + `((,mat-sym ,x) + (,(gensym "sto") (store ,mat-sym)) + (,(gensym "strides") (strides ,mat-sym)) + (,(gensym "dimensions") (dimensions ,mat-sym))))) + mats))) + (with-gensyms (i j dims) + `(let (,@(apply #'append syms) + (,dims ,dims-e)) + (loop :for ,i :from 0 :below (aref ,dims 0) + :do (loop :for ,j :from 0 :below (aref ,dims 1) + :do (progn + ,@body))))))) + (deft/generic t/copy-upper-triangle (sym #'subtypep) (a b) (using-gensyms (decl (a b)) (with-gensyms (sto-a sto-b strd-a strd-b) commit 2247ca7cc973977e061ee894efee10faec823f1d Author: Akshay Srinivasan <aks...@gm...> Date: Sun Sep 15 11:55:55 2013 -0700 Saving working state on geqr. diff --git a/src/foreign-core/lapack.lisp b/src/foreign-core/lapack.lisp index b587e50..1c94e74 100644 --- a/src/foreign-core/lapack.lisp +++ b/src/foreign-core/lapack.lisp @@ -1068,7 +1068,7 @@ (m :integer :input) (n :integer :input) (k :integer :input) - (a (* :complex-double-float) :input-output) + (a (* :complex-double-float :inc head-a) :input-output) (lda :integer :input) (tau (* :complex-double-float) :input) (work (* :complex-double-float) :workspace-output) @@ -1236,7 +1236,7 @@ (m :integer :input) (n :integer :input) (k :integer :input) - (a (* :double-float) :input-output) + (a (* :double-float :inc head-a) :input-output) (lda :integer :input) (tau (* :double-float) :input) (work (* :double-float) :workspace-output) diff --git a/src/lapack/geqr.lisp b/src/lapack/geqr.lisp index 3d129a1..17c1818 100644 --- a/src/lapack/geqr.lisp +++ b/src/lapack/geqr.lisp @@ -1,43 +1,26 @@ -;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Package: :matlisp; Base: 10 -*- -;;; -;;; $Id: geqr.lisp,v 1.7 2002/01/20 00:42:25 simsek Exp $ -;;; -;;; $Log: geqr.lisp,v $ -;;; Revision 1.7 2002/01/20 00:42:25 simsek -;;; o removed a spurious ignore -;;; -;;; Revision 1.6 2002/01/08 19:40:45 rtoy -;;; The functions we use are exported now. -;;; -;;; Revision 1.5 2001/10/29 18:00:28 rtoy -;;; Updates from M. Koerber to support QR routines with column pivoting: -;;; -;;; o Add an integer4 type and allocate-integer4-store routine. -;;; o Add the necessary Fortran routines -;;; o Add Lisp interface to the Fortran routines -;;; o Update geqr for the new routines. -;;; -;;; Revision 1.4 2001/10/29 17:34:34 rtoy -;;; I (RLT) stupidly deleted too much from M. Koerber's update. This is -;;; his latest version. -;;; -;;; Revision 1.3 2001/10/26 15:19:25 rtoy -;;; Renamed optional SKINNY parameter to ECON. -;;; -;;; Revision 1.2 2001/10/26 13:37:03 rtoy -;;; Correctly handle the case when rows > cols and we want the [q1 q2] -;;; form. Fix from M. Koerber. -;;; -;;; Revision 1.1 2001/10/25 21:51:58 rtoy -;;; Initial revision for QR routines. -;;; - (in-package #:matlisp) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Set up the methods required to handle general matricies of Real -;; and complex types. There are numerous other special cases, but -;; they will not be considered for this first release. mak +(deft/generic (t/lapack-geqrf-func #'subtypep) sym ()) +(deft/method t/lapack-geqrf-func (sym real-tensor) () + 'matlisp-lapack:dgeqrf) +(deft/method t/lapack-geqrf-func (sym complex-tensor) () + 'matlisp-lapack:zgeqrf) +;; +(deft/generic (t/lapack-geqrf-workspace-inquiry #'subtypep) sym (m n)) +(deft/method t/lapack-geqrf-workspace-inquiry (sym blas-numeric-tensor) (m n) + (using-gensyms (decl (m n)) + (with-gensyms (xxx) + `(let (,@decl + (,xxx (t/store-allocator ,sym 1))) + (declare (type index-type ,m ,n) + (type ,(store-type sym) ,xxx)) + (,(macroexpand-1 `(t/lapack-geqrf-func ,sym)) + ,m ,n + ,xxx ,m + ,xxx ,xxx -1 0) + (ceiling (t/frealpart ,(field-type sym) (t/store-ref ,sym ,xxx 0))))))) + +;; (defgeneric geqr! (a) (:documentation " @@ -61,68 +44,59 @@ [2] R If the factorization can not be done, Q and R are set to NIL. - - NOTE: THIS FUNCTION IS DESTRUCTIVE. -")) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; One could simply use LWORK = (MAX 1 N), but this call might result -;; in some optimization in performance. For small matricies this is -;; probably a 'no-net-gain' operation...but I seldom use small matricies -;; in my work ;-) ... mak -(let ((xx (allocate-real-store 1)) - (work (allocate-real-store 1))) - - (defun dgeqrf-workspace-inquiry (m n) - (multiple-value-bind (store-a store-tau store-work lwork info) - (lapack:dgeqrf m n xx m xx work -1 0) - - (declare (ignore store-a store-tau store-work lwork info)) - - (values (ceiling (realpart (aref work 0))))))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(let ((xx (allocate-complex-store 1)) - (work (allocate-complex-store 1))) - - (defun zgeqrf-workspace-inquiry (m n) - - (multiple-value-bind (store-a store-tau store-work lwork info) - (lapack:zgeqrf m n xx m xx work -1 0) - - (declare (ignore store-a store-tau store-work lwork info)) - - (values (ceiling (realpart (aref work 0))))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Okay...now we build up the specific method for real and comples -(defmethod geqr! ((a real-matrix)) - - (let* ((m (nrows a)) - (n (ncols a)) - (k (min m n)) ; THESE ROUTINES ONLY RETURN A MINIMUM Q! - (tau (allocate-real-store k)) ; reflection factors - (lwork (dgeqrf-workspace-inquiry m n)) ; optimum work array size - (work (allocate-real-store lwork))) ; and the work area - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; Do the Householder portion of the decomposition - (multiple-value-bind (q-r new-tau new-work info) - (lapack:dgeqrf m n (store a) m tau work lwork 0) - - (declare (ignore new-work)) - ;; Q-R and NEW-TAU aren't needed either since the (STORE A) and WORK - ;; get modified - - (if (not (zerop info)) - ;; If INFO is not zero, then an error occured. Return Nil - ;; for the Q and R and print a warning - (progn (warn "QR Decomp failed: Argument ~d in call to DGEQRF is bad" (- info)) - (values nil nil)) - - ;; If we are here, then INFO == 0 and all is well... - (let ((r (make-real-matrix k n))) +") + (:method :before ((a standard-tensor)) + (assert (tensor-matrixp a) nil 'tensor-dimension-mismatch))) + + +(defmacro loop-upper-triangle (cla +(deft/generic t/copy-upper-triangle (sym #'subtypep) (a b) + (using-gensyms (decl (a b)) + (with-gensyms (sto-a sto-b strd-a strd-b) + `(let (,@decl + (,sto-a (store ,a)) + (,strd-a (strides ,a)) + (,sto-b (store ,b)) + (,strd-b (strides ,b))) + (declare (type ,sym ,a ,b) + (type ,(store-type sym) ,sto-a ,sto-b) + (type index-store-vector ,strd-a ,strd-b)) + (very-quickly + (loop :repeat (nrows ,a) + :for rof-a :of-type index-type := (head a) :then (+ rof-a (aref strd-a 0)) + :for rof-a :of-type index-type := (head a) :then (+ rof-a (aref strd-a 0)) + :do (loop :repeat (ncols b) + :do (t/store-set ,sym (t/store-ref ,sym sto-a ..) sto-b ..)))))))))) + +(defmethod geqr! ((a standard-tensor)) + (let ((cla (class-name (class-of A)))) + (assert (member cla *tensor-type-leaves*) + nil 'tensor-abstract-class :tensor-class (list cla)) + (compile-and-eval + `(defmethod geqr! ((a ,cla)) + (let* ((m (nrows a)) + (n (ncols a)) + (k (min m n)) ; THESE ROUTINES ONLY RETURN A MINIMUM Q! + (tau (t/store-allocator ,cla k)) ; reflection factors + (lwork (t/lapack-geqrf-workspace-inquiry m n)) ; optimum work array size + (work (t/store-allocator ,cla lwork))) ; and the work area + (declare (type index-type lwork m n k) + (type ,(store-type cla) tau work)) + ;; Do the Householder portion of the decomposition + (with-columnification (,cla () (A)) + (multiple-value-bind (q-r new-tau new-work info) + (,(macroexpand-1 `(t/lapack-geqrf-func ,cla)) + m n + (the ,(store-type cla) (store A)) (or (blas-matrix-compatiblep A #\N) 0) + tau work lwork 0 (the index-type (head A))) + (declare (ignore q-r new-tau new-work)) + (unless (= info 0) + (error "geqrf returned ~a~%" info)) + + + + ;; If we are here, then INFO == 0 and all is well... + (let ((r (make-real-matrix k n))) ;; Extract the matrix R from Q-R (dotimes (row k) (loop for col from row below n do commit e41ab636a047d01b438e86d24ad4b5169d0edfe2 Author: Akshay Srinivasan <aks...@gm...> Date: Sat Sep 14 12:03:29 2013 -0700 Made real-version of eig more generic. diff --git a/src/lapack/eig.lisp b/src/lapack/eig.lisp index c603342..f0a92da 100644 --- a/src/lapack/eig.lisp +++ b/src/lapack/eig.lisp @@ -199,8 +199,6 @@ vl vr))))))) (geev! A vl vr)) ;; - - (defgeneric eig (matrix &optional job) (:method :before ((matrix standard-tensor) &optional (job :nn)) (assert (tensor-matrixp matrix) nil 'tensor-dimension-mismatch) @@ -213,7 +211,6 @@ (vr (when revec? (zeros (list n n) (class-of matrix))))) (geev! (copy matrix) vl vr))) - (defun geev-fix-up-eigvec (n eigval eigvec) (let* ((evec (copy! eigvec (zeros (list n n) (complexified-type (class-of eigvec))))) (tmp (zeros n (complexified-type (class-of eigvec)))) @@ -236,19 +233,17 @@ (return nil))) evec)) -(defmethod eig ((matrix real-tensor) &optional (job :nn)) +(defmethod eig ((matrix real-numeric-tensor) &optional (job :nn)) (mlet* ((n (nrows matrix)) ((levec? revec?) (values-list (mapcar #'(lambda (x) (char= x #\V)) (split-job job)))) (ret (multiple-value-list (geev! (copy matrix) - (when levec? (zeros (list n n) 'real-tensor)) - (when revec? (zeros (list n n) 'real-tensor))))) + (when levec? (zeros (list n n) (class-of matrix))) + (when revec? (zeros (list n n) (class-of matrix)))))) (eig (car ret))) - (if (let ((stoe (store eig))) - (loop :for i :from 0 :below n - :do (unless (zerop (t/fc (t/field-type complex-tensor) (t/store-ref complex-tensor stoe i))) - (return nil)) - :finally (return t))) - (values-list ret) - (values-list (cons eig (mapcar #'(lambda (mat) (geev-fix-up-eigvec n eig mat)) (cdr ret))))))) - + (if (loop :for i :from 0 :below n + :do (unless (zerop (imagpart (ref eig i))) + (return nil)) + :finally (return t)) + (values-list ret) + (values-list (cons eig (mapcar #'(lambda (mat) (geev-fix-up-eigvec n eig mat)) (cdr ret))))))) diff --git a/src/lapack/geev.lisp b/src/lapack/geev.lisp deleted file mode 100644 index 9789585..0000000 --- a/src/lapack/geev.lisp +++ /dev/null @@ -1,524 +0,0 @@ -;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Package: :matlisp; Base: 10 -*- -;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Copyright (c) 2000 The Regents of the University of California. -;;; All rights reserved. -;;; -;;; Permission is hereby granted, without written agreement and without -;;; license or royalty fees, to use, copy, modify, and distribute this -;;; software and its documentation for any purpose, provided that the -;;; above copyright notice and the following two paragraphs appear in all -;;; copies of this software. -;;; -;;; IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY -;;; FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES -;;; ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF -;;; THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF -;;; SUCH DAMAGE. -;;; -;;; THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, -;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF -;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE -;;; PROVIDED HEREUNDER IS ON AN "AS IS" BASIS, AND THE UNIVERSITY OF -;;; CALIFORNIA HAS NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, -;;; ENHANCEMENTS, OR MODIFICATIONS. -;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Originally written by Raymond Toy -;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; $Id: geev.lisp,v 1.11 2005/08/20 13:50:27 rtoy Exp $ -;;; -;;; $Log: geev.lisp,v $ -;;; Revision 1.11 2005/08/20 13:50:27 rtoy -;;; Fix problem with geev-workspace-inquiry functions when given a job -;;; of :vv. This is a slightly modified version of the patch by Paul -;;; Ledbetter III, on matlisp-user, 2005-08-16. -;;; -;;; We also removed the extra xxx array and used work instead. -;;; -;;; Revision 1.10 2001/10/26 15:24:16 rtoy -;;; From M. Koerber: -;;; -;;; When determining LWORK, if JOBVR is V, the LDVR must be >= N. -;;; -;;; Revision 1.9 2001/06/22 12:52:41 rtoy -;;; Use ALLOCATE-REAL-STORE and ALLOCATE-COMPLEX-STORE to allocate space -;;; instead of using the error-prone make-array. -;;; -;;; Revision 1.8 2001/03/07 00:14:56 rtoy -;;; Asking dgeev for the desired workspace size now works. (Didn't have -;;; the return values matched up correctly!) (Needs a fix to dgeev.f for -;;; this to work, though.) -;;; -;;; Revision 1.7 2001/03/06 21:58:06 rtoy -;;; o The workspace inquiry function doesn't seem to work for DGEEV. -;;; Don't use it in geev. -;;; o The workspace was too small when inquiring the workspace for ZGEEV. -;;; Make it larger. -;;; -;;; Revision 1.6 2001/02/23 14:04:20 rtoy -;;; The Fortran geev routines allow the user to inquire about the optimum -;;; size of the work array. Use that to allocate the appropriate amount -;;; of space. -;;; -;;; Revision 1.5 2001/02/23 13:13:56 rtoy -;;; The length of the work array was half-sized! (Despite the name, -;;; complex-matrix-element-type is not a complex number. It's just a real -;;; number) -;;; -;;; Revision 1.4 2000/07/11 18:02:03 simsek -;;; o Added credits -;;; -;;; Revision 1.3 2000/07/11 02:11:56 simsek -;;; o Added support for Allegro CL -;;; -;;; Revision 1.2 2000/05/08 17:19:18 rtoy -;;; Changes to the STANDARD-MATRIX class: -;;; o The slots N, M, and NXM have changed names. -;;; o The accessors of these slots have changed: -;;; NROWS, NCOLS, NUMBER-OF-ELEMENTS -;;; The old names aren't available anymore. -;;; o The initargs of these slots have changed: -;;; :nrows, :ncols, :nels -;;; -;;; Revision 1.1 2000/04/14 00:11:12 simsek -;;; o This file is adapted from obsolete files 'matrix-float.lisp' -;;; 'matrix-complex.lisp' and 'matrix-extra.lisp' -;;; o Initial revision. -;;; -;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(in-package #:matlisp) - -(defgeneric geev (a &optional job) - (:documentation - " - Syntax - ====== - (GEEV a [job]) - - Purpose: - ======== - Computes the eigenvalues and left/right eigenvectors of A. - - For an NxN matrix A, its eigenvalues are denoted by: - - lambda(i), j = 1 ,..., N - - The right eigenvectors of A are denoted by v(i) where: - - A * v(i) = lambda(i) * v(i) - - The left eigenvectors of A are denoted by u(i) where: - - H H - u(i) * A = lambda(i) * u(i) - - In matrix notation: - -1 - A = V E V - - and - -1 - H H - A = U E U - - where lambda(i) is the ith diagonal of the diagonal matrix E, - v(i) is the ith column of V and u(i) is the ith column of U. - - The computed eigenvectors are normalized to have Euclidean norm - equal to 1 and largest component real. - - Return Values: - ============== - - JOB Return Values - ------------------------------------------------------------------ - :NN (default) [1] (DIAG E) An Nx1 vector of eigenvalues - [2] INFO - - :VN or T [1] V - [2] E - [3] INFO - - :NV [1] E - [2] U - [3] INFO - - :VV [1] V - [2] E - [3] U - [3] INFO - - where INFO is T if successful, NIL otherwise. -")) - - -(defmethod geev :before ((a standard-matrix) &optional (job :NN)) - (if (not (square-matrix-p a)) - (error "argument A given to GEEV is not a square matrix") - (if (not (member job '(:nn nn :vn vn :nv nv :vv vv t))) - (error "argument JOB given to GEEV is not recognized")))) - -(defun geev-fix-up-eigvec (n real-eig-p eigval eigvec) - (if real-eig-p - (make-instance 'real-matrix :nrows n :ncols n :store eigvec) - ;; We have to carefully handle complex-valued eigenvectors and eigenvalues - (let ((evec (make-complex-matrix n n))) - (do ((col 0 (incf col)) - (posn 0)) - ((>= col n) evec) - (cond ((zerop (aref eigval col)) - (dotimes (row n) - (setf (matrix-ref evec row col) (aref eigvec posn)) - (incf posn))) - (t - (dotimes (row n) - (let ((next-posn (+ posn n))) - (setf (matrix-ref evec row col) - (complex (aref eigvec posn) (aref eigvec next-posn))) - (setf (matrix-ref evec row (1+ col)) - (complex (aref eigvec posn) (- (aref eigvec next-posn)))) - (incf posn))) - ;; Skip over the next column, which we've already used - (incf col) - (incf posn n))))))) - -(defun geev-fix-up-eigen (n wr wi vr vl left-eig right-eig) - (let ((res nil) - ;; Eigenvalues are real unless the max of wi is not zero. - (real-eig (zerop (aref wi (1- (blas::idamax n wi 1)))))) - - (when right-eig - (push (geev-fix-up-eigvec n real-eig wi vr) res)) - - (if real-eig - (if (or right-eig left-eig) - (let ((eigval (make-real-matrix n n))) - (dotimes (k n) - (setf (matrix-ref eigval k k) (aref wr k))) - (push eigval res)) - (let ((eigval (make-real-matrix n 1))) - (dotimes (k n) - (setf (matrix-ref eigval k) (aref wr k))) - (push eigval res))) - (if (or right-eig left-eig) - (let ((eigval (make-complex-matrix n n))) - (dotimes (k n) - (setf (matrix-ref eigval k k) (complex (aref wr k) (aref wi k)))) - (push eigval res)) - (let ((eigval (make-complex-matrix n 1))) - (dotimes (k n) - (setf (matrix-ref eigval k) (complex (aref wr k) (aref wi k)))) - (push eigval res)))) - - (when left-eig - (push (geev-fix-up-eigvec n real-eig wi vl) res)) - - (push t res) - (values-list (nreverse res)))) - - -(let ((work (allocate-real-store 1))) - (defun dgeev-workspace-inquiry (n job) - ;; Ask geev how much space it wants for the work array - (multiple-value-bind (jobvl jobvr) - (case job - (:nn (values "N" "N")) - ((:vn t) (values "N" "V")) - (:nv (values "V" "N")) - (:vv (values "V" "V"))) - - (let* ((ldvr (if (equal jobvr "V") n 1)) - (ldvl (if (equal jobvl "V") n 1))) - - (multiple-value-bind (store-a store-wr store-wi store-vl store-vr - work info) - (dgeev jobvl - jobvr - n ; N - work ; A - n ; LDA - work ; WR - work ; WI - work ; VL - ldvl ; LDVL - work ; VR - ldvr ; LDVR - work ; WORK - -1 ; LWORK - 0 ) ; INFO - (declare (ignore store-a store-wr store-wi store-vl store-vr)) - (assert (zerop info)) - (ceiling (realpart (aref work 0)))))))) - - -(defmethod geev ((a real-matrix) &optional (job :NN)) - (let* ((n (nrows a)) - (a (copy a)) - (xxx (allocate-real-store 1)) - (wr (allocate-real-store n)) - (wi (allocate-real-store n)) - (lwork (dgeev-workspace-inquiry n job)) - (work (allocate-real-store lwork))) - - (declare (type fixnum n) - (type (simple-array real-matrix-element-type (*)) xxx wr wi)) - - (case job - (:nn - (multiple-value-bind (a wr wi vl vr work info) - (dgeev "N" ; JOBVL - "N" ; JOBVR - n ; N - (store a) ; A - n ; LDA - wr ; WR - wi ; WI - xxx ; VL - 1 ; LDVL - xxx ; VR - 1 ; LDVR - work ; WORK - lwork ; LWORK - 0 ) ; INFO - (declare (ignore a work)) - (if (zerop info) - (geev-fix-up-eigen n wr wi vr vl nil nil) - (values nil nil)))) - - ((:vn t) - (let* ((vr (allocate-real-store (* n n)))) - (multiple-value-bind (a wr wi vl vr work info) - (dgeev "N" ;; JOBVL - "V" ;; JOBVR - n ;; N - (store a) ;; A - n ;; LDA - wr ;; WR - wi ;; WI - xxx ;; VL - 1 ;; LDVL - vr ;; VR - n ;; LDVR - work ;; WORK - lwork ;; LWORK - 0 ) ;; INFO - (declare (ignore a work)) - (if (zerop info) - (geev-fix-up-eigen n wr wi vr vl nil t) - (values nil nil))))) - - (:nv - (let* ((vl (allocate-real-store (* n n)))) - - (multiple-value-bind (a wr wi vl vr work info) - (dgeev "V" ;; JOBVL - "N" ;; JOBVR - n ;; N - (store a) ;; A - n ;; LDA - wr ;; WR - wi ;; WI - vl ;; VL - n ;; LDVL - xxx ;; VR - 1 ;; LDVR - work ;; WORK - lwork ;; LWORK - 0 ) ;; INFO - (declare (ignore a work)) - (if (zerop info) - (geev-fix-up-eigen n wr wi vr vl t nil) - (values nil nil))))) - - (:vv - (let* ((vl (allocate-real-store (* n n))) - (vr (allocate-real-store (* n n)))) - - (multiple-value-bind (a wr wi vl vr work info) - (dgeev "V" ;; JOBVL - "V" ;; JOBVR - n ;; N - (store a) ;; A - n ;; LDA - wr ;; WR - wi ;; WI - vl ;; VL - n ;; LDVL - vr ;; VR - n ;; LDVR - work ;; WORK - lwork ;; LWORK - 0 ) ;; INFO - (declare (ignore a work)) - (if (zerop info) - (geev-fix-up-eigen n wr wi vr vl t t) - (values nil nil))))) - - - ))) - - -(let ((work (allocate-complex-store 1))) - (defun zgeev-workspace-inquiry (n job) - ;; Ask geev how much space it wants for the work array - (multiple-value-bind (jobvl jobvr) - (case job - (:nn (values "N" "N")) - ((:vn t) (values "N" "V")) - (:nv (values "V" "N")) - (:vv (values "V" "V"))) - (let* ((ldvr (if (equal jobvr "V") n 1)) - (ldvl (if (equal jobvl "V") n 1))) - (multiple-value-bind (store-a store-w store-vl store-vr work info) - (zgeev jobvl - jobvr - n ; N - work ; A - n ; LDA - work ; W - work ; VL - 1 ; LDVL - work ; VR - ldvr ; LDVR - work ; WORK - -1 ; LWORK - work ; RWORK - 0 ) ; INFO - (declare (ignore store-a store-w store-vl store-vr info)) - ;; The desired size in in work[0], which we convert to an - ;; integer. - (ceiling (aref work 0))))))) - -;; Hmm, should this really be 4 (5) different methods, one for each -;; possible value of job? - -(defmethod geev ((a complex-matrix) &optional (job :NN)) - (let* ((n (nrows a)) - (a (copy a)) - (w (make-complex-matrix-dim n 1)) - (xxx (allocate-complex-store 1)) - (lwork (zgeev-workspace-inquiry n job)) - (work (allocate-complex-store lwork)) - (rwork (allocate-complex-store n))) - - (declare (type fixnum lwork n) - (type (simple-array complex-matrix-element-type (*)) xxx work) - (type (simple-array real-matrix-element-type (*)) rwork)) - - (case job - (:nn - (multiple-value-bind (store-a store-w store-vl store-vr work info) - (zgeev "N" ; JOBVL - "N" ; JOBVR - n ; N - (store a) ; A - n ; LDA - (store w) ; W - xxx ; VL - 1 ; LDVL - xxx ; VR - 1 ; LDVR - work ; WORK - lwork ; LWORK - rwork ; RWORK - 0 ) ; INFO - (declare (ignore store-a store-w store-vl store-vr work)) - (if (zerop info) - (values w t) - (values nil nil)))) - - ((:vn t) - (let* ((vr (make-complex-matrix-dim n n))) - - (multiple-value-bind (store-a store-w store-vl store-vr work info) - (zgeev "N" ;; JOBVL - "V" ;; JOBVR - n ;; N - (store a) ;; A - n ;; LDA - (store w) ;; W - xxx ;; VL - 1 ;; LDVL - (store vr) ;; VR - n ;; LDVR - work ;; WORK - lwork ;; LWORK - rwork ;; RWORK - 0 ) ;; INFO - (declare (ignore store-a store-w store-vl store-vr work)) - (if (zerop info) - (values vr (diag w) t) - (values nil nil))))) - - (:nv - (let* ((vl (make-complex-matrix-dim n n))) - - (multiple-value-bind (store-a store-w store-vl store-vr work info) - (zgeev "V" ;; JOBVL - "N" ;; JOBVR - n ;; N - (store a) ;; A - n ;; LDA - (store w) ;; W - (store vl) ;; VL - n ;; LDVL - xxx ;; VR - 1 ;; LDVR - work ;; WORK - lwork ;; LWORK - rwork ;; RWORK - 0 ) ;; INFO - (declare (ignore store-a store-w store-vl store-vr work)) - (if (zerop info) - (values (diag w) vl t) - (values nil nil))))) - - (:vv - (let* ((vr (make-complex-matrix-dim n n)) - (vl (make-complex-matrix-dim n n))) - - - (multiple-value-bind (store-a store-w store-vl store-vr work info) - (zgeev "V" ;; JOBVL - "V" ;; JOBVR - n ;; N - (store a) ;; A - n ;; LDA - (store w) ;; W - (store vl) ;; VL - n ;; LDVL - (store vr) ;; VR - n ;; LDVR - work ;; WORK - lwork ;; LWORK - rwork ;; RWORK - 0 ) ;; INFO - (declare (ignore store-a store-w store-vl store-vr work)) - (if (zerop info) - (values vr (diag w) vl t) - (values nil nil))))) - - - ))) - - - -(defun eig (a &optional (job :nn)) - " - Syntax - ====== - (EIG a [job]) - - Purpose - ======= - Computes the eigenvalues and left/right eigenvector of A. - - EIG is an alias for GEEV, for more help see GEEV. -" - (geev a job)) ----------------------------------------------------------------------- Summary of changes: lib-src/gnuplot/gnuplot.lisp | 22 ++- packages.lisp | 5 +- src/base/einstein.lisp | 26 +-- src/foreign-core/lapack.lisp | 4 +- src/lapack/eig.lisp | 23 +-- src/lapack/geev.lisp | 524 ------------------------------------------ src/lapack/geqr.lisp | 154 +++++-------- src/lapack/lu.lisp | 3 + src/level-1/copy.lisp | 30 +++ src/level-2/gemv.lisp | 2 +- src/level-3/gemm.lisp | 10 +- src/special/map.lisp | 4 + src/utilities/functions.lisp | 24 ++ src/utilities/macros.lisp | 55 +++++- tests/loopy-tests.lisp | 21 +- 15 files changed, 224 insertions(+), 683 deletions(-) delete mode 100644 src/lapack/geev.lisp hooks/post-receive -- matlisp |
From: Akshay S. <ak...@us...> - 2013-09-11 21:25:41
|
This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "matlisp". The branch, tensor has been updated via f8b87a620796e228cadb86996b85f4298409ed75 (commit) via d5f56f654435a06be255e30e2f660360e6920ced (commit) via 739477d2ea4ae8e582b2355220d502443cd722a3 (commit) from c6c440e0043ee6633cb729a0bc590e9ca97d5eff (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- ----------------------------------------------------------------------- Summary of changes: configure | 8 +++ configure.ac | 8 +++ lib-src/gnuplot/gnuplot.lisp | 54 ++++++++++++++++----- lib-src/matlisp/Makefile.am | 3 +- packages.lisp | 1 + src/base/print.lisp | 4 +- src/base/standard-tensor.lisp | 88 ++++++++++++++++++--------------- src/classes/numeric.lisp | 2 +- src/conditions.lisp | 7 +++ src/foreign-core/lazy-loader.lisp.in | 6 +- src/lapack/eig.lisp | 56 +++++++++++++++++++++- src/lapack/geqr.lisp | 2 +- src/level-2/gemv.lisp | 5 ++ src/old/foreign-real-matrix.lisp | 2 +- src/old/help.lisp | 1 - src/packages/odepack/dlsode.lisp | 86 ++++++++++++++++++++++++++++++-- src/special/map.lisp | 27 ++++++++-- 17 files changed, 284 insertions(+), 76 deletions(-) hooks/post-receive -- matlisp |
From: Akshay S. <ak...@us...> - 2013-09-10 20:52:35
|
This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "matlisp". The branch, classy has been updated via f8b87a620796e228cadb86996b85f4298409ed75 (commit) via d5f56f654435a06be255e30e2f660360e6920ced (commit) via 739477d2ea4ae8e582b2355220d502443cd722a3 (commit) from c6c440e0043ee6633cb729a0bc590e9ca97d5eff (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit f8b87a620796e228cadb86996b85f4298409ed75 Author: Akshay Srinivasan <aks...@gm...> Date: Tue Sep 10 13:44:24 2013 -0700 Made changes to build on a Mac. diff --git a/configure b/configure index 097bf32..5a562fa 100755 --- a/configure +++ b/configure @@ -15464,6 +15464,14 @@ else fi +#Create libdir if missing (seems to be an issue on the Mac) +if test -d $libdir; then + echo "libdir: Directory present" +else + echo "libdir: Directory not present, creating." + mkdir $libdir +fi; + # Check to see if the BLAS library is compatible with matlisp's # ffi. Basically the same test as above that checks to see if -ff2c # is needed. We call zdotu which is a Fortran function returning a diff --git a/configure.ac b/configure.ac index 6b0aeba..bce467b 100644 --- a/configure.ac +++ b/configure.ac @@ -313,6 +313,14 @@ AC_HELP_STRING([--with-external-blas-lapack=libpath], [Location of the BLAS/LAPA ]) AM_CONDITIONAL([EXT_BLAPACK], [test x$ext_blapack = xtrue]) +#Create libdir if missing (seems to be an issue on the Mac) +if test -d $libdir; then + echo "libdir: Directory present" +else + echo "libdir: Directory not present, creating." + mkdir $libdir +fi; + # Check to see if the BLAS library is compatible with matlisp's # ffi. Basically the same test as above that checks to see if -ff2c # is needed. We call zdotu which is a Fortran function returning a diff --git a/lib-src/matlisp/Makefile.am b/lib-src/matlisp/Makefile.am index 63da032..37703b4 100644 --- a/lib-src/matlisp/Makefile.am +++ b/lib-src/matlisp/Makefile.am @@ -13,5 +13,4 @@ compat.f\ descal.f\ zescal.f\ dediv.f\ -zediv.f\ -xerbla.f +zediv.f diff --git a/lib-src/matlisp/xerbla.f b/lib-src/matlisp/xerbla.f deleted file mode 100644 index 5de4b64..0000000 --- a/lib-src/matlisp/xerbla.f +++ /dev/null @@ -1,41 +0,0 @@ - SUBROUTINE XERBLA(SRNAME,INFO) -* -* -- LAPACK auxiliary routine (preliminary version) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - INTEGER INFO - CHARACTER*6 SRNAME -* .. -* -* Purpose -* ======= -* -* XERBLA is an error handler for the LAPACK routines. -* It is called by an LAPACK routine if an input parameter has an -* invalid value. A message is printed and execution stops. -* -* Installers may consider modifying the STOP statement in order to -* call system-specific exception-handling facilities. -* -* Arguments -* ========= -* -* SRNAME (input) CHARACTER*6 -* The name of the routine which called XERBLA. -* -* INFO (input) INTEGER -* The position of the invalid parameter in the parameter list -* of the calling routine. -* -* - WRITE (*,FMT=9999) SRNAME,INFO -* -* - 9999 FORMAT (' ** On entry to ',A6,' parameter number ',I2,' had ', - + 'an illegal value') -* -* End of XERBLA -* - END diff --git a/src/foreign-core/lazy-loader.lisp.in b/src/foreign-core/lazy-loader.lisp.in index f7e5b4e..025c65e 100644 --- a/src/foreign-core/lazy-loader.lisp.in +++ b/src/foreign-core/lazy-loader.lisp.in @@ -72,10 +72,10 @@ (progn (push "@BLAS_LAPACK_DIR@" cffi:*foreign-library-directories*) (cffi:define-foreign-library blas - (:darwin "libblas.dylib") + (:darwin (:or "libBLAS.dylib" "libblas.dylib")) (t (:default "@BLAS_LAPACK_DIR@/libblas"))) (cffi:define-foreign-library lapack - (:darwin "liblapack.dylib") + (:darwin (:or "libLAPACK.dylib" "liblapack.dylib")) (t (:default "@BLAS_LAPACK_DIR@/liblapack")))) (progn ;; Use our blas and lapack libraries @@ -88,8 +88,8 @@ (defun load-blas-&-lapack-libraries () ;; Load the additional matlisp libraries - (cffi:use-foreign-library matlisp) (cffi:use-foreign-library blas) + (cffi:use-foreign-library matlisp) (cffi:use-foreign-library lapack) (cffi:use-foreign-library dfftpack) (cffi:use-foreign-library toms715) diff --git a/src/lapack/eig.lisp b/src/lapack/eig.lisp index 94bee6a..c603342 100644 --- a/src/lapack/eig.lisp +++ b/src/lapack/eig.lisp @@ -191,7 +191,7 @@ (values-list (remove-if #'null (list (let ((*check-after-initializing?* nil)) - (make-instance 'complex-tensor ;',(complexified-type cla) + (make-instance ',(complexified-type cla) :dimensions (make-index-store (list (nrows A))) :strides (make-index-store (list 1)) :head 0 @@ -213,10 +213,10 @@ (vr (when revec? (zeros (list n n) (class-of matrix))))) (geev! (copy matrix) vl vr))) + (defun geev-fix-up-eigvec (n eigval eigvec) - (declare (type complex-tensor eigval) - (type real-tensor eigvec)) - (let* ((evec (copy! eigvec (zeros (list n n) 'complex-tensor))) + (let* ((evec (copy! eigvec (zeros (list n n) (complexified-type (class-of eigvec))))) + (tmp (zeros n (complexified-type (class-of eigvec)))) (cviewa (col-slice~ evec 0)) (cviewb (col-slice~ evec 0)) (cst (aref (strides evec) 1))) @@ -228,9 +228,10 @@ (progn (setf (slot-value cviewa 'head) (* i cst) (slot-value cviewb 'head) (* (1+ i) cst)) - (axpy! #c(0d0 1d0) cviewb cviewa) - (scal! #c(0d0 -2d0) cviewb) - (axpy! #c(1d0 0d0) cviewa cviewb) + (copy! cviewb tmp) + (copy! cviewa cviewb) + (axpy! #c(0 1) tmp cviewa) + (axpy! #c(0 -1) tmp cviewb) (incf i 2))) (return nil))) evec)) diff --git a/src/lapack/geqr.lisp b/src/lapack/geqr.lisp index 3bdf501..3d129a1 100644 --- a/src/lapack/geqr.lisp +++ b/src/lapack/geqr.lisp @@ -32,7 +32,7 @@ ;;; Initial revision for QR routines. ;;; -(in-package "MATLISP") +(in-package #:matlisp) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Set up the methods required to handle general matricies of Real commit d5f56f654435a06be255e30e2f660360e6920ced Author: Akshay Srinivasan <aks...@gm...> Date: Sun Sep 8 01:02:54 2013 -0700 Added eig. diff --git a/lib-src/matlisp/xerbla.f b/lib-src/matlisp/xerbla.f new file mode 100644 index 0000000..5de4b64 --- /dev/null +++ b/lib-src/matlisp/xerbla.f @@ -0,0 +1,41 @@ + SUBROUTINE XERBLA(SRNAME,INFO) +* +* -- LAPACK auxiliary routine (preliminary version) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO + CHARACTER*6 SRNAME +* .. +* +* Purpose +* ======= +* +* XERBLA is an error handler for the LAPACK routines. +* It is called by an LAPACK routine if an input parameter has an +* invalid value. A message is printed and execution stops. +* +* Installers may consider modifying the STOP statement in order to +* call system-specific exception-handling facilities. +* +* Arguments +* ========= +* +* SRNAME (input) CHARACTER*6 +* The name of the routine which called XERBLA. +* +* INFO (input) INTEGER +* The position of the invalid parameter in the parameter list +* of the calling routine. +* +* + WRITE (*,FMT=9999) SRNAME,INFO +* +* + 9999 FORMAT (' ** On entry to ',A6,' parameter number ',I2,' had ', + + 'an illegal value') +* +* End of XERBLA +* + END diff --git a/src/classes/numeric.lisp b/src/classes/numeric.lisp index e266cfc..f360bf9 100644 --- a/src/classes/numeric.lisp +++ b/src/classes/numeric.lisp @@ -97,7 +97,7 @@ (imagpart (imagpart element))) (format stream (if (zerop imagpart) "~11,5,,,,,'Eg" - "#C(~11,4,,,,,'Ee ~11,4,,,,,'Ee)") + "#C(~0,4,,,,,'Ee, ~0,4,,,,,'Ee)") realpart imagpart))) ;; (defleaf complex-tensor (complex-numeric-tensor) ()) diff --git a/src/lapack/eig.lisp b/src/lapack/eig.lisp index 923aee7..94bee6a 100644 --- a/src/lapack/eig.lisp +++ b/src/lapack/eig.lisp @@ -198,3 +198,56 @@ :store (t/geev-output-fix ,cla wr wi))) vl vr))))))) (geev! A vl vr)) +;; + + +(defgeneric eig (matrix &optional job) + (:method :before ((matrix standard-tensor) &optional (job :nn)) + (assert (tensor-matrixp matrix) nil 'tensor-dimension-mismatch) + (assert (member job '(:nn :nv :vn :vv)) nil 'invalid-arguments))) + +(defmethod eig ((matrix complex-numeric-tensor) &optional (job :nn)) + (mlet* ((n (nrows matrix)) + ((levec? revec?) (values-list (mapcar #'(lambda (x) (char= x #\V)) (split-job job)))) + (vl (when levec? (zeros (list n n) (class-of matrix)))) + (vr (when revec? (zeros (list n n) (class-of matrix))))) + (geev! (copy matrix) vl vr))) + +(defun geev-fix-up-eigvec (n eigval eigvec) + (declare (type complex-tensor eigval) + (type real-tensor eigvec)) + (let* ((evec (copy! eigvec (zeros (list n n) 'complex-tensor))) + (cviewa (col-slice~ evec 0)) + (cviewb (col-slice~ evec 0)) + (cst (aref (strides evec) 1))) + (loop + :with i := 0 + :do (if (< i n) + (if (zerop (imagpart (ref eigval i))) + (incf i) + (progn + (setf (slot-value cviewa 'head) (* i cst) + (slot-value cviewb 'head) (* (1+ i) cst)) + (axpy! #c(0d0 1d0) cviewb cviewa) + (scal! #c(0d0 -2d0) cviewb) + (axpy! #c(1d0 0d0) cviewa cviewb) + (incf i 2))) + (return nil))) + evec)) + +(defmethod eig ((matrix real-tensor) &optional (job :nn)) + (mlet* ((n (nrows matrix)) + ((levec? revec?) (values-list (mapcar #'(lambda (x) (char= x #\V)) (split-job job)))) + (ret (multiple-value-list + (geev! (copy matrix) + (when levec? (zeros (list n n) 'real-tensor)) + (when revec? (zeros (list n n) 'real-tensor))))) + (eig (car ret))) + (if (let ((stoe (store eig))) + (loop :for i :from 0 :below n + :do (unless (zerop (t/fc (t/field-type complex-tensor) (t/store-ref complex-tensor stoe i))) + (return nil)) + :finally (return t))) + (values-list ret) + (values-list (cons eig (mapcar #'(lambda (mat) (geev-fix-up-eigvec n eig mat)) (cdr ret))))))) + diff --git a/src/level-2/gemv.lisp b/src/level-2/gemv.lisp index f793ccd..3dfb285 100644 --- a/src/level-2/gemv.lisp +++ b/src/level-2/gemv.lisp @@ -157,3 +157,8 @@ (defmethod gemv (alpha (A standard-tensor) (x standard-tensor) beta (y standard-tensor) &optional (job :n)) (gemv! alpha A x beta (copy y) job)) + +(defmethod gemv (alpha (A standard-tensor) (x standard-tensor) + (beta (eql nil)) (y (eql nil)) &optional (job :n)) + (let ((ret (zeros (nrows A) (class-of A)))) + (gemv! alpha A x 1 ret job))) diff --git a/src/old/foreign-real-matrix.lisp b/src/old/foreign-real-matrix.lisp index a0c0248..6d933b1 100644 --- a/src/old/foreign-real-matrix.lisp +++ b/src/old/foreign-real-matrix.lisp @@ -34,4 +34,4 @@ (declare (type fixnum n m)) (make-instance 'foreign-real-matrix :nrows n :ncols m - :store store)) \ No newline at end of file + :store store)) diff --git a/src/old/help.lisp b/src/old/help.lisp index 38f0e68..dbebe14 100644 --- a/src/old/help.lisp +++ b/src/old/help.lisp @@ -236,4 +236,3 @@ For example, (HELP matlisp) (HELP mapcar)") (format stream "~&~%No documentation available for symbol ~a" item) (values))))) - commit 739477d2ea4ae8e582b2355220d502443cd722a3 Author: Akshay Srinivasan <aks...@gm...> Date: Tue Aug 27 15:41:13 2013 -0700 Added a nicer dlsode interface. Added stuff to the gnuplot interface. diff --git a/lib-src/gnuplot/gnuplot.lisp b/lib-src/gnuplot/gnuplot.lisp index d34a360..f9b48dc 100644 --- a/lib-src/gnuplot/gnuplot.lisp +++ b/lib-src/gnuplot/gnuplot.lisp @@ -2,11 +2,20 @@ (defvar *current-gnuplot-process* nil) (defun open-gnuplot-stream (&optional (gnuplot-binary (pathname "/usr/bin/gnuplot"))) - (#+:sbcl - sb-ext:run-program - #+:ccl - ccl:run-program - gnuplot-binary nil :input :stream :wait nil :output t)) + (setf *current-gnuplot-process* (#+:sbcl + sb-ext:run-program + #+:ccl + ccl:run-program + gnuplot-binary nil :input :stream :wait nil :output t)) + (gnuplot-send " +set datafile fortran +") + *current-gnuplot-process*) + +(defun close-gnuplot-stream () + (when *current-gnuplot-process* + (gnuplot-send "quit~%") + (setf *current-gnuplot-process* nil))) (defun gnuplot-send (str &rest args) (unless *current-gnuplot-process* @@ -19,14 +28,35 @@ (apply #'format (append (list stream str) args)) (finish-output stream))) -(defun plot2d (data &key (lines t) (color (list "#FF0000"))) - (with-open-file (s "/tmp/matlisp-gnuplot.out" :direction :output :if-exists :supersede :if-does-not-exist :create) - (loop :for i :from 0 :below (loop :for x :in data :minimizing (size x)) - :do (loop :for x :in data :do (format s "~a " (coerce (ref x i) 'single-float)) :finally (format s "~%")))) - (if lines - (gnuplot-send "plot '/tmp/matlisp-gnuplot.out' with lines linecolor rgb ~s~%" color) - (gnuplot-send "plot '/tmp/matlisp-gnuplot.out'~%"))) +(defun splitcol (num) + (multiple-value-bind (a b0) (floor num 256) + (multiple-value-bind (b2 b1) (floor a 256) + (list b2 b1 b0)))) +(defun plot2d (data &key (lines t) (color nil)) + (let ((fname "/tmp/matlisp-gnuplot.out")) + (with-open-file (s fname :direction :output :if-exists :supersede :if-does-not-exist :create) + (loop :for i :from 0 :below (loop :for x :in data :minimizing (size x)) + :do (loop :for x :in data :do (format s "~a " (coerce (ref x i) 'single-float)) :finally (format s "~%")))) + (let ((col (if (listp color) color + (let ((lst (list color))) + (setf (cdr lst) lst) + lst)))) + (let ((cmd (apply #'string+ (cons "plot " (loop :for x :in (cdr data) + :for i := 2 :then (1+ i) + :for clist := col :then (cdr clist) + :collect (string+ "'" fname "' using 1:" (format nil "~a " i) + "with " (if lines "lines" "points") " " + (if (car clist) + (apply #'(lambda (r g b) (format nil "linecolor rgb(~a, ~a, ~a)" r g b)) + (splitcol (car clist))) + "") + (format nil "title \"~a\"" (1- i)) + ", ")))))) + (setf (aref cmd (- (length cmd) 2)) #\; + (aref cmd (- (length cmd) 1)) #\Newline) + (gnuplot-send cmd))))) + ;; (defclass gnuplot-plot-info () ;; ((title ;; :initform "GNU PLOT" diff --git a/packages.lisp b/packages.lisp index 04096db..f3d665d 100644 --- a/packages.lisp +++ b/packages.lisp @@ -61,6 +61,7 @@ #:tensor-cannot-find-counter-class #:tensor-cannot-find-optimization #:tensor-dimension-mismatch + #:tensor-type-mismatch #:tensor-store-not-consecutive #:tensor-method-does-not-exist #:tensor-abstract-class diff --git a/src/base/print.lisp b/src/base/print.lisp index d058298..3ad6c7f 100644 --- a/src/base/print.lisp +++ b/src/base/print.lisp @@ -29,13 +29,13 @@ (in-package #:matlisp) ;; Routines for printing a tensors/matrices nicely. -(defparameter *print-max-len* 5 +(defparameter *print-max-len* 10 " Maximum number of elements in any particular argument to print. Set this to T to print all the elements. ") -(defparameter *print-max-args* 2 +(defparameter *print-max-args* 5 " Maximum number of arguments of the tensor to print. Set this to T to print all the arguments. diff --git a/src/base/standard-tensor.lisp b/src/base/standard-tensor.lisp index 426536f..cccd99b 100644 --- a/src/base/standard-tensor.lisp +++ b/src/base/standard-tensor.lisp @@ -397,46 +397,54 @@ (declare (type standard-tensor tensor) (type list subscripts) (type boolean preserve-rank)) - (let-typed ((dims (dimensions tensor) :type index-store-vector) - (stds (strides tensor) :type index-store-vector) - (rank (rank tensor) :type index-type)) - (loop :for (start step end) :in subscripts - :for i :of-type index-type := 0 :then (1+ i) - :with ndims :of-type index-store-vector := (allocate-index-store rank) - :with nstds :of-type index-store-vector := (allocate-index-store rank) - :with nrank :of-type index-type := 0 - :with nhd :of-type index-type := (head tensor) - :do (assert (< i rank) nil 'tensor-index-rank-mismatch :index-rank (1+ i) :rank rank) - :do (let* ((start (if (eq start '*) 0 - (progn - (assert (and (typep start 'index-type) (< -1 start (aref dims i))) nil 'tensor-index-out-of-bounds :argument i :index start :dimension (aref dims i)) - start))) - (step (if (eq step '*) 1 - (progn - (assert (and (typep step 'index-type) (< 0 step)) nil 'invalid-value :given step :expected '(< 0 step) :message "STEP cannot be <= 0.") - step))) - (end (if (eq end '*) (aref dims i) - (progn - (assert (and (typep end 'index-type) (<= 0 end (aref dims i))) nil 'tensor-index-out-of-bounds :argument i :index start :dimension (aref dims i)) - end)))) - (declare (type index-type start step end)) - ;; - (let-typed ((dim (ceiling (the index-type (- end start)) step) :type index-type)) - (unless (and (= dim 1) (not preserve-rank)) - (setf (aref ndims nrank) dim - (aref nstds nrank) (* step (aref stds i))) - (incf nrank)) - (when (/= start 0) - (incf nhd (the index-type (* start (aref stds i))))))) - :finally (return - (if (= nrank 0) (store-ref tensor nhd) - (let ((*check-after-initializing?* nil)) - (make-instance (class-of tensor) - :head nhd - :dimensions (very-quickly (vectorify (the index-store-vector ndims) nrank 'index-type)) - :strides (very-quickly (vectorify (the index-store-vector nstds) nrank 'index-type)) - :store (store tensor) - :parent-tensor tensor))))))) + (if (null subscripts) + (let ((*check-after-initializing?* nil)) + (make-instance (class-of tensor) + :head (head tensor) + :dimensions (copy-seq (dimensions tensor)) + :strides (copy-seq (strides tensor)) + :store (store tensor) + :parent-tensor tensor)) + (let-typed ((dims (dimensions tensor) :type index-store-vector) + (stds (strides tensor) :type index-store-vector) + (rank (rank tensor) :type index-type)) + (loop :for (start step end) :in subscripts + :for i :of-type index-type := 0 :then (1+ i) + :with ndims :of-type index-store-vector := (allocate-index-store rank) + :with nstds :of-type index-store-vector := (allocate-index-store rank) + :with nrank :of-type index-type := 0 + :with nhd :of-type index-type := (head tensor) + :do (assert (< i rank) nil 'tensor-index-rank-mismatch :index-rank (1+ i) :rank rank) + :do (let* ((start (if (eq start '*) 0 + (progn + (assert (and (typep start 'index-type) (< -1 start (aref dims i))) nil 'tensor-index-out-of-bounds :argument i :index start :dimension (aref dims i)) + start))) + (step (if (eq step '*) 1 + (progn + (assert (and (typep step 'index-type) (< 0 step)) nil 'invalid-value :given step :expected '(< 0 step) :message "STEP cannot be <= 0.") + step))) + (end (if (eq end '*) (aref dims i) + (progn + (assert (and (typep end 'index-type) (<= 0 end (aref dims i))) nil 'tensor-index-out-of-bounds :argument i :index start :dimension (aref dims i)) + end)))) + (declare (type index-type start step end)) + ;; + (let-typed ((dim (ceiling (the index-type (- end start)) step) :type index-type)) + (unless (and (= dim 1) (not preserve-rank)) + (setf (aref ndims nrank) dim + (aref nstds nrank) (* step (aref stds i))) + (incf nrank)) + (when (/= start 0) + (incf nhd (the index-type (* start (aref stds i))))))) + :finally (return + (if (= nrank 0) (store-ref tensor nhd) + (let ((*check-after-initializing?* nil)) + (make-instance (class-of tensor) + :head nhd + :dimensions (very-quickly (vectorify (the index-store-vector ndims) nrank 'index-type)) + :strides (very-quickly (vectorify (the index-store-vector nstds) nrank 'index-type)) + :store (store tensor) + :parent-tensor tensor)))))))) (definline slice~ (x axis &optional (idx 0)) (let ((slst (make-list (rank x) :initial-element '(* * *)))) diff --git a/src/conditions.lisp b/src/conditions.lisp index d396359..dc7efc0 100644 --- a/src/conditions.lisp +++ b/src/conditions.lisp @@ -218,6 +218,13 @@ (declare (ignore c)) (format stream "The dimensions of the given tensors are not suitable for continuing with the operation.")))) +(define-condition tensor-type-mismatch (tensor-error) + () + (:documentation "The types of the given tensors are not suitable for continuing with the operation.") + (:report (lambda (c stream) + (declare (ignore c)) + (format stream "The types of the given tensors are not suitable for continuing with the operation.")))) + (define-condition tensor-store-not-consecutive (tensor-error) () (:documentation "The strides of the store, of the given tensor are not conscutive.") diff --git a/src/packages/odepack/dlsode.lisp b/src/packages/odepack/dlsode.lisp index 466603c..15206e6 100644 --- a/src/packages/odepack/dlsode.lisp +++ b/src/packages/odepack/dlsode.lisp @@ -15,7 +15,7 @@ (c-y (* :double-float :size c-neq) :input) (c-ydot (* :double-float :size c-neq) :output))) (neq :integer :input) - (y (* :double-float) :input-output) + (y (* :double-float :inc head-y) :input-output) (ts :double-float :input-output) (tout :double-float :input) (itol :integer :input) @@ -40,6 +40,55 @@ (mf :integer :input)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun ode-evolve (field y0 t-array) + (declare (type real-tensor y0 t-array)) + (assert (and (tensor-vectorp t-array) (tensor-vectorp y0)) nil 'tensor-dimension-mismatch) + (let* ((neq (size y0)) + (nt (size t-array)) + (t0 (ref t-array 0)) + (ts t0) + (ret (zeros (list neq nt) 'real-tensor)) + ;; + (lrw (+ 22 (* 9 neq) (* neq neq) 5)) + (liw (+ 20 neq 5)) + (itol 1) + (atol (make-array 1 :element-type 'double-float :initial-element 1d-12)) + (rtol (make-array 1 :element-type 'double-float :initial-element 1d-12)) + (itask 1) + (istate 1) + (iopt 0) + (mf 22) + (rwork (make-array lrw :element-type 'double-float :initial-element 0d0)) + (iwork (make-array liw :element-type '(signed-byte 32) :initial-element 0)) + ;; + (view (slice~ ret 1)) + (stv (aref (strides ret) 1)) + ;; + (y-tmp (zeros neq 'real-tensor)) + (stoy (store y-tmp))) + (copy! y0 view) + (incf (slot-value view 'head) stv) + (labels ((field-sugar (neq time yf ydotf) + (loop :for i :from 0 :below neq + :do (t/store-set real-tensor (fv-ref yf i) stoy i)) + ;;Because of some black magic, this does not seem to + ;;affect the amount of memory allocated! + (let ((ydot (funcall field time y-tmp))) + (loop :for i :from 0 :below neq + :do (setf (fv-ref ydotf i) (ref ydot i)))) + nil)) + (loop :for i :from 1 :below nt + :do (let ((tout (ref t-array i))) + (multiple-value-bind (y-out ts-out istate-out rwork-out iwork-out) + (dlsode #'field-sugar neq (store y0) ts tout itol rtol atol itask istate iopt rwork lrw iwork liw #'(lambda (&rest th) (declare (ignore th))) mf (head y0)) + (declare (ignore y-out rwork-out iwork-out)) + (setq ts ts-out) + (setq istate istate-out)) + (copy! y0 view) + (incf (slot-value view 'head) stv)))) + ret)) +;; + (defun lsode-evolve (field y t-array report) ;; (let* ((neq (length y)) @@ -61,7 +110,7 @@ do (progn (setq tout (aref t-array i)) (multiple-value-bind (y-out ts-out istate-out rwork-out iwork-out) - (dlsode field neq y ts tout itol rtol atol itask istate iopt rwork lrw iwork liw #'(lambda (&rest th) (declare (ignore th))) mf) + (dlsode field neq (store y) ts tout itol rtol atol itask istate iopt rwork lrw iwork liw #'(lambda (&rest th) (declare (ignore th))) mf) (setq ts ts-out) (setq istate istate-out)) (funcall report ts y))))) @@ -74,10 +123,32 @@ (defun pend-report (ts y) (format t "~A ~A ~A ~%" ts (aref y 0) (aref y 1))) -(defun pcart-field (neq time y ydot) - (declare (ignore neq time)) - (very-quickly - (destructuring-bind (x theta xdot thetadot) (mapcar #'(lambda (n) (fv-ref y n)) '(0 1 2 3)) +(defun pcart-field (time y ydot) + (declare (ignore time)) + (destructuring-bind (x theta xdot thetadot) (mapslice #'id y) + (setf (ref ydot 0) xdot + (ref ydot 1) thetadot + (ref ydot 2) (/ (+ (* (cos theta) (sin theta)) (* (sin theta) (expt thetadot 2))) (- 2 (expt (cos theta) 2))) + (ref ydot 3) (/ (+ (* 2 (sin theta)) (* (cos theta) (sin theta) (expt thetadot 2))) (- (expt (cos theta) 2) 2))))) + +(defun pcart-field (time y) + (declare (ignore time)) + (let ((ydot (zeros 4 'real-tensor))) + (destructuring-bind (x theta xdot thetadot) (mapslice #'id y) + (setf (ref ydot 0) xdot + (ref ydot 1) thetadot + (ref ydot 2) (/ (+ (* (cos theta) (sin theta)) (* (sin theta) (expt thetadot 2))) (- 2 (expt (cos theta) 2))) + (ref ydot 3) (/ (+ (* 2 (sin theta)) (* (cos theta) (sin theta) (expt thetadot 2))) (- (expt (cos theta) 2) 2)))) + ydot)) + + +(defun pcart-report (ts y) + (format t "~A ~A ~A ~A ~A ~%" ts (aref y 0) (aref y 1) (aref y 2) (aref y 3))) + + +(defun pcart-field (time y ydot) + (declare (ignore time)) + (destructuring-bind (x theta xdot thetadot) (mapcar #'(lambda (n) (fv-ref y n)) '(0 1 2 3)) (declare (type double-float x theta xdot thetadot)) (setf (fv-ref ydot 0) xdot (fv-ref ydot 1) thetadot @@ -87,6 +158,7 @@ (defun pcart-report (ts y) (format t "~A ~A ~A ~A ~A ~%" ts (aref y 0) (aref y 1) (aref y 2) (aref y 3))) + #+nil (let ((y (make-array 2 :element-type 'double-float :initial-contents `(,(/ pi 2) 0d0)))) (lsode-evolve #'pend-field y #(0d0 1d0 2d0) #'pend-report)) @@ -94,6 +166,8 @@ ;; 1.0d0 1.074911802207049d0 -0.975509986605856d0 ;; 2.0d0 -0.20563950412081608d0 -1.3992359518735706d0 +(ode-evolve #'pcart-field (copy! (list 0 (/ pi 3) 0 0) (zeros 4)) (range 0 10)) + #+nil (let ((y (make-array 4 :element-type 'double-float :initial-contents `(0d0 ,(/ pi 3) 0d0 0d0))) diff --git a/src/special/map.lisp b/src/special/map.lisp index 9cb083a..98b8443 100644 --- a/src/special/map.lisp +++ b/src/special/map.lisp @@ -40,13 +40,28 @@ y))) (mapsor! func x y)) ;; -(defun mapslice (func x &optional (axis 1)) + +(defun mapslice (func x &optional (axis 0)) + (declare (type standard-tensor x)) + (if (tensor-vectorp x) + (loop :for i :from 0 :below (aref (dimensions x) axis) + :collect (funcall func (ref x i))) + (let* ((v-x (slice~ x axis)) + (st-x (aref (strides x) axis))) + (loop :for i :from 0 :below (aref (the index-store-vector (dimensions x)) axis) + :collect (prog1 (funcall func (copy v-x)) + (incf (slot-value v-x 'head) st-x)))))) + +(defun mapslice~ (func x &optional (axis 0)) (declare (type standard-tensor x)) - (let* ((v-x (slice~ x axis)) - (st-x (aref (strides x) axis))) - (loop :for i :from 0 :below (aref (the index-store-vector (dimensions x)) axis) - :collect (prog1 (funcall func (copy v-x)) - (incf (slot-value v-x 'head) st-x))))) + (if (tensor-vectorp x) + (loop :for i :from 0 :below (aref (dimensions x) axis) + :collect (funcall func (ref x i))) + (let* ((v-x (slice~ x axis)) + (st-x (aref (strides x) axis))) + (loop :for i :from 0 :below (aref (the index-store-vector (dimensions x)) axis) + :collect (prog1 (funcall func (sub-tensor~ v-x nil)) + (incf (slot-value v-x 'head) st-x)))))) (defmacro tensor-foldl (type func ten init &optional (init-type (field-type type))) (using-gensyms (decl (ten init)) ----------------------------------------------------------------------- Summary of changes: configure | 8 +++ configure.ac | 8 +++ lib-src/gnuplot/gnuplot.lisp | 54 ++++++++++++++++----- lib-src/matlisp/Makefile.am | 3 +- packages.lisp | 1 + src/base/print.lisp | 4 +- src/base/standard-tensor.lisp | 88 ++++++++++++++++++--------------- src/classes/numeric.lisp | 2 +- src/conditions.lisp | 7 +++ src/foreign-core/lazy-loader.lisp.in | 6 +- src/lapack/eig.lisp | 56 +++++++++++++++++++++- src/lapack/geqr.lisp | 2 +- src/level-2/gemv.lisp | 5 ++ src/old/foreign-real-matrix.lisp | 2 +- src/old/help.lisp | 1 - src/packages/odepack/dlsode.lisp | 86 ++++++++++++++++++++++++++++++-- src/special/map.lisp | 27 ++++++++-- 17 files changed, 284 insertions(+), 76 deletions(-) hooks/post-receive -- matlisp |
From: Akshay S. <ak...@us...> - 2013-08-24 03:34:32
|
This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "matlisp". The branch, tensor has been updated via c6c440e0043ee6633cb729a0bc590e9ca97d5eff (commit) via 6fb6102eb0a39b2bf48ba2dfbe98f2d7a1966935 (commit) via 60f2b8490d5a31c90886c51d081bdb802f5431d6 (commit) via 050548a939e93208a4990b6de248e3e39b3caa45 (commit) via 7aa696273c37819ebc5b9ee1040d0f194dd8145a (commit) via 570ae7eb80324580ee27cfa7ba1d20b11f779e41 (commit) via 79a87b8605dba8ae97c8f354e42f1f081b127771 (commit) via fc524fd099c95abfc3af0280e8a200e461cc9493 (commit) via a3ea5898fd82c16b66bf0ce3d5615e370deb40a8 (commit) via 69ca54a98c4e4a03e004268297644094b5541cae (commit) via 6c6f96e88fab82f42a2cd563c53e90c48eb8da24 (commit) via 1f3bc86e39b2b9d1a23946434486a99faf9d7eaf (commit) via fd0546544cd3c21641688e03ff221b031ac01ae4 (commit) via 62f126ef664982e0c8ffd132ade8bb5308833f56 (commit) via 9afd000d1a6b497e3bf4fdc0318884b412773de7 (commit) via a7bad8cec909a69bb312917406d3dfc1626f8c12 (commit) via 831a7c79908907c3702b623d0eae3a0a1f746a58 (commit) via 05cd941088d8c303f3b5f81d34a6fb336f1033a9 (commit) via f051c33ed570af222cff1fbf93802dc8844034ad (commit) via f314da645424005358b1921156218063d8ea64c2 (commit) via f47066fa8877ca56d4d58f36a5a08515593b8a2f (commit) via 1894d2f6b21c756ec5bb2ddd443e6d38a7087f2b (commit) via 808353d428ddc07d365bf1de8abcc86f0179ee08 (commit) via f9bf6a61b1860942b520069596563b2db546f927 (commit) via be4148122456b5f7a6d4032fcba44e4652f4eb0b (commit) via 228188fe426f884dd6a1743578e879350b7050ec (commit) via 03eedb3f3faa199ef9b76c30b95d4222d98dd9be (commit) via 7e8e80cf438552059d8d05797da5a4f9320127d3 (commit) via 222aee503ad0678516eaae1e638b016fb01efb09 (commit) via 5f237cd125d3d50ae322fdeaf1db314f0562830e (commit) via 95d41cef90f67e4d0b50ca7679ce5b5bffdd7532 (commit) via 8273423d3f82d599972086c6263975bfebe6c3a2 (commit) via d7210a4b81356e32907afde8bcd13d4cbf97dd00 (commit) via 1407d41f3f3150a905e8cf33e07db5042651f8ae (commit) via 4248b0bfbfb4fda8e99fee6edad8383f2afcf606 (commit) via ecbc68d2926eb4dc1299401beb741e3551a3941d (commit) via 50fcc688d2f72e751722b74e994808ad90f4c1ce (commit) via c108b24c014b002d9d0465ed895a8223a766230a (commit) via 0b071d4d11400da962b99cbff50ee42afc443b0b (commit) via ca0287f4334829367de787ba0e20947f53b6298c (commit) via 24def88c5b5227b29154cee9e05d88d119ceade8 (commit) via ea151122023fbd5d481a831645292fa3232b7b8b (commit) via e6de232ea94a34325a971da0355eecf472c7769c (commit) via f3d0633327f4ceba538ccb2657552b6069850bfe (commit) via 9f01a9f4f148c9a00ad80d5eacffd667db2cbbb7 (commit) via 83545ebc9021cad75969d41c803f5a4557c61e9a (commit) from ba36a2d0877b66fc5b6b4055b9310b2e60a54186 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- ----------------------------------------------------------------------- Summary of changes: AUTHORS | 3 + configure | 167 +++++++++- lib-src/gnuplot/gnuplot.lisp | 25 +- lib-src/matlisp/Makefile.am | 3 +- lib-src/matlisp/dediv.f | 6 +- lib-src/matlisp/descal.f | 4 +- lib-src/matlisp/zediv.f | 9 +- lib-src/matlisp/zescal.f | 4 +- matlisp.asd | 45 ++- packages.lisp | 61 ++-- src/base/blas-helpers.lisp | 154 +++++---- src/base/einstein.lisp | 243 +++++++++++++ src/base/generic-copy.lisp | 79 +++-- src/base/loopy.lisp | 152 ++++----- src/base/permutation.lisp | 46 ++- src/base/print.lisp | 6 +- src/base/standard-tensor.lisp | 524 ++++++++++++----------------- src/base/template.lisp | 239 +++++++++++++ src/base/tweakable.lisp | 8 +- src/classes/complex-tensor.lisp | 159 --------- src/classes/matrix.lisp | 25 +- src/classes/numeric.lisp | 111 ++++++ src/classes/real-tensor.lisp | 114 ------- src/conditions.lisp | 7 + src/ffi/c-ffi.lisp | 13 +- src/ffi/f77-ffi.lisp | 617 +++++++++++++++++----------------- src/ffi/ffi-cffi.lisp | 4 + src/foreign-core/blas.lisp | 94 +++--- src/foreign-core/lapack.lisp | 66 ++-- src/foreign-core/lazy-loader.lisp.in | 7 +- src/lapack/chol.lisp | 177 ++++++++++ src/lapack/eig.lisp | 200 +++++++++++ src/lapack/geev.lisp | 42 +-- src/lapack/getrs.lisp | 185 ---------- src/lapack/{getrf.lisp => lu.lisp} | 203 ++++++++---- src/lapack/potrf.lisp | 145 -------- src/lapack/potrs.lisp | 217 ------------ src/lapack/svd.lisp | 2 - src/level-1/axpy.lisp | 273 +++++---------- src/level-1/copy.lisp | 377 +++++++-------------- src/level-1/dot.lisp | 231 ++++++-------- src/level-1/maker.lisp | 34 ++ src/level-1/realimag.lisp | 36 +-- src/level-1/scal.lisp | 460 ++++++++----------------- src/level-1/sum.lisp | 65 ++++ src/level-1/swap.lisp | 119 ++++---- src/level-1/tensor-maker.lisp | 91 ----- src/level-1/trans.lisp | 12 +- src/level-2/gemv.lisp | 296 ++++++----------- src/level-3/gemm.lisp | 517 ++++++---------------------- src/old/loopy-old.lisp | 118 ------- src/packages/odepack/dlsode.lisp | 5 +- src/special/map.lisp | 70 ++++ src/special/random.lisp | 76 +++++ src/{sugar => special}/seq.lisp | 36 ++- src/utilities/circular-buffer.lisp | 51 +++ src/utilities/functions.lisp | 303 ++++++++++------- src/utilities/lvec.lisp | 2 +- src/utilities/macros.lisp | 13 + src/utilities/template.lisp | 104 ++++++ tests/loopy-tests.lisp | 75 ++++- tests/tcomp.lisp | 74 ++++ 62 files changed, 3787 insertions(+), 3817 deletions(-) create mode 100644 src/base/einstein.lisp create mode 100644 src/base/template.lisp delete mode 100644 src/classes/complex-tensor.lisp create mode 100644 src/classes/numeric.lisp delete mode 100644 src/classes/real-tensor.lisp create mode 100644 src/lapack/chol.lisp create mode 100644 src/lapack/eig.lisp delete mode 100644 src/lapack/getrs.lisp rename src/lapack/{getrf.lisp => lu.lisp} (50%) delete mode 100644 src/lapack/potrf.lisp delete mode 100644 src/lapack/potrs.lisp create mode 100644 src/level-1/maker.lisp create mode 100644 src/level-1/sum.lisp delete mode 100644 src/level-1/tensor-maker.lisp delete mode 100644 src/old/loopy-old.lisp create mode 100644 src/special/map.lisp create mode 100644 src/special/random.lisp rename src/{sugar => special}/seq.lisp (70%) create mode 100644 src/utilities/circular-buffer.lisp create mode 100644 src/utilities/template.lisp create mode 100644 tests/tcomp.lisp hooks/post-receive -- matlisp |
From: Akshay S. <ak...@us...> - 2013-08-24 03:33:49
|
This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "matlisp". The branch, classy has been updated via c6c440e0043ee6633cb729a0bc590e9ca97d5eff (commit) via 6fb6102eb0a39b2bf48ba2dfbe98f2d7a1966935 (commit) via 60f2b8490d5a31c90886c51d081bdb802f5431d6 (commit) via 050548a939e93208a4990b6de248e3e39b3caa45 (commit) via 7aa696273c37819ebc5b9ee1040d0f194dd8145a (commit) via 570ae7eb80324580ee27cfa7ba1d20b11f779e41 (commit) via 79a87b8605dba8ae97c8f354e42f1f081b127771 (commit) via fc524fd099c95abfc3af0280e8a200e461cc9493 (commit) via a3ea5898fd82c16b66bf0ce3d5615e370deb40a8 (commit) via 69ca54a98c4e4a03e004268297644094b5541cae (commit) via 6c6f96e88fab82f42a2cd563c53e90c48eb8da24 (commit) via 1f3bc86e39b2b9d1a23946434486a99faf9d7eaf (commit) via fd0546544cd3c21641688e03ff221b031ac01ae4 (commit) via 62f126ef664982e0c8ffd132ade8bb5308833f56 (commit) via 9afd000d1a6b497e3bf4fdc0318884b412773de7 (commit) via a7bad8cec909a69bb312917406d3dfc1626f8c12 (commit) via 831a7c79908907c3702b623d0eae3a0a1f746a58 (commit) via 05cd941088d8c303f3b5f81d34a6fb336f1033a9 (commit) via f051c33ed570af222cff1fbf93802dc8844034ad (commit) via f314da645424005358b1921156218063d8ea64c2 (commit) via f47066fa8877ca56d4d58f36a5a08515593b8a2f (commit) via 1894d2f6b21c756ec5bb2ddd443e6d38a7087f2b (commit) from 808353d428ddc07d365bf1de8abcc86f0179ee08 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit c6c440e0043ee6633cb729a0bc590e9ca97d5eff Author: Akshay Srinivasan <aks...@gm...> Date: Fri Aug 23 20:33:50 2013 -0700 Added seq, map functions. diff --git a/matlisp.asd b/matlisp.asd index 44384f4..b4b9ac0 100644 --- a/matlisp.asd +++ b/matlisp.asd @@ -168,7 +168,9 @@ (:module "matlisp-special" :pathname "special" :depends-on ("matlisp-base" "matlisp-classes" "matlisp-level-1" "matlisp-level-2" "matlisp-level-3") - :components ((:file "random"))) + :components ((:file "random") + (:file "map") + (:file "seq"))) #+nil (:module "matlisp-sugar" :pathname "sugar" diff --git a/src/base/generic-copy.lisp b/src/base/generic-copy.lisp index 543fa5c..aa30346 100644 --- a/src/base/generic-copy.lisp +++ b/src/base/generic-copy.lisp @@ -78,6 +78,10 @@ y)) (copy! x y))) +(defmethod copy! ((x cons) (y standard-tensor)) + ;;You seriously weren't expecting efficiency were you :) ? + (let ((arr (make-array (list-dimensions x) :initial-contents x))) + (copy! arr y))) ;; (defgeneric copy (object) (:documentation diff --git a/src/classes/numeric.lisp b/src/classes/numeric.lisp index 6f3e87e..e266cfc 100644 --- a/src/classes/numeric.lisp +++ b/src/classes/numeric.lisp @@ -53,8 +53,9 @@ (deft/method t/l3-lb (sym complex-numeric-tensor) () '*complex-l3-fcall-lb*) -;;SBCL uses specialized arrays for floating complex arrays. -#-sbcl +;;Comment this block if you want to use (simple-array (complex double-float) (*)) +;;as the underlying store. This will make Lisp-implementations of gemm .. faster +;;but you'll lose the ability to use tensor-realpart~/imagpart~. (progn (deft/method t/store-element-type (sym complex-numeric-tensor) () (let ((cplx-type (macroexpand-1 `(t/field-type ,sym)))) diff --git a/src/level-1/map.lisp b/src/level-1/map.lisp deleted file mode 100644 index 3359ea9..0000000 --- a/src/level-1/map.lisp +++ /dev/null @@ -1,72 +0,0 @@ -(in-package #:matlisp) - -(defgeneric mapsor! (func x y) - (:documentation " - y <- func(x) -") - (:method :before ((func function) (x standard-tensor) (y standard-tensor)) - (assert (very-quickly (lvec-eq (dimensions x) (dimensions y))) nil 'tensor-dimension-mismatch))) - -(defmethod mapsor! ((func function) (x standard-tensor) (y standard-tensor)) - (let ((clx (class-name (class-of x))) - (cly (class-name (class-of y)))) - (assert (and - (member clx *tensor-type-leaves*) - (member cly *tensor-type-leaves*)) - nil 'tensor-abstract-class :tensor-class (list clx cly)) - (compile-and-eval - `(defmethod mapsor! ((func function) (x ,clx) (y ,cly)) - (let ((sto-x (store x)) - (sto-y (store y))) - (declare (type ,(store-type clx) sto-x) - (type ,(store-type cly) sto-y)) - (very-quickly - (mod-dotimes (idx (dimensions x)) - :with (linear-sums - (of-x (strides x)) - (of-y (strides y))) - :do (t/store-set ,cly (funcall func (t/store-ref ,clx sto-x of-x)) sto-y of-y)))) - y))) - (mapsor! func x y)) - -(defun mapcol (func x &optional (axis 1)) - (declare (type standard-tensor x)) - (assert (tensor-matrixp x) nil 'tensor-dimension-mismatch) - (let* ((v-x (slice~ x axis)) - (st-x (aref (the index-store-vector (strides x)) axis)) - (ret (zeros (aref (the index-store-vector (dimensions x)) axis) (class-of x)))) - (loop :for i :from 0 :below (aref (the index-store-vector (dimensions x)) axis) - :do (progn - (setf (ref ret i) (funcall func v-x)) - (incf (slot-value v-x 'head) st-x))) - ret)) - -(defun tensor-min (x) - (let ((min nil)) - (mod-dotimes (idx (dimensions x)) - :do (when (or (null min) (< (ref x idx) min)) - (setf min (ref x idx)))) - min)) - -(defun idx-min (v) - (let ((min-idx nil) - (min nil)) - (loop :for i :from 0 :below (aref (the index-store-vector (dimensions v)) 0) - :do (when (or (null min) (< (ref v i) min)) - (setf min-idx i - min (ref v i)))) - (values min-idx min))) - -(defun mapxis! (func x y &optional (axis 0)) - (declare (type standard-tensor x y)) - (multiple-value-bind (view-x view-y) (let ((slst (make-list (rank x) :initial-element '(* * *)))) - (rplaca (nthcdr axis slst) (list 0 '* 1)) - (values (sub-tensor~ x slst nil) (sub-tensor~ y slst nil))) - (let ((st-x (aref (the index-store-vector (dimensions x)) axis)) - (st-y (aref (the index-store-vector (dimensions x)) axis))) - (loop :for i :from 0 :below (aref (the index-store-vector (dimensions x)) axis) - :do (progn - ;;May die if you're doing fancy stuff. - (funcall func view-x view-y) - - diff --git a/src/special/map.lisp b/src/special/map.lisp new file mode 100644 index 0000000..9cb083a --- /dev/null +++ b/src/special/map.lisp @@ -0,0 +1,70 @@ +(in-package #:matlisp) + +(defgeneric mapsor! (func x y) + (:documentation " + Syntax + ====== + (MAPSOR! func x y) + + Purpose + ======= + Applies the function element-wise on x, and sets the corresponding + elements in y to the value returned by the function. + + Example + ======= + > (mapsor! #'sin (randn '(2 2)) (zeros '(2 2))) +") + (:method :before ((func function) (x standard-tensor) (y standard-tensor)) + (assert (very-quickly (lvec-eq (dimensions x) (dimensions y))) nil 'tensor-dimension-mismatch))) + +(defmethod mapsor! ((func function) (x standard-tensor) (y standard-tensor)) + (let ((clx (class-name (class-of x))) + (cly (class-name (class-of y)))) + (assert (and + (member clx *tensor-type-leaves*) + (member cly *tensor-type-leaves*)) + nil 'tensor-abstract-class :tensor-class (list clx cly)) + (compile-and-eval + `(defmethod mapsor! ((func function) (x ,clx) (y ,cly)) + (let ((sto-x (store x)) + (sto-y (store y))) + (declare (type ,(store-type clx) sto-x) + (type ,(store-type cly) sto-y)) + (very-quickly + (mod-dotimes (idx (dimensions x)) + :with (linear-sums + (of-x (strides x)) + (of-y (strides y))) + :do (t/store-set ,cly (funcall func (t/store-ref ,clx sto-x of-x)) sto-y of-y)))) + y))) + (mapsor! func x y)) +;; +(defun mapslice (func x &optional (axis 1)) + (declare (type standard-tensor x)) + (let* ((v-x (slice~ x axis)) + (st-x (aref (strides x) axis))) + (loop :for i :from 0 :below (aref (the index-store-vector (dimensions x)) axis) + :collect (prog1 (funcall func (copy v-x)) + (incf (slot-value v-x 'head) st-x))))) + +(defmacro tensor-foldl (type func ten init &optional (init-type (field-type type))) + (using-gensyms (decl (ten init)) + (with-gensyms (sto idx of funcsym) + `(let* (,@decl + ,@(unless (symbolp func) + `((,funcsym ,func))) + (,sto (store ,ten))) + (declare (type ,type ,ten) + ,@(unless (symbolp func) `((type function ,funcsym))) + (type ,(store-type type) ,sto) + ,@(when init-type + `((type ,init-type ,init)))) + (very-quickly + (mod-dotimes (,idx (dimensions ,ten)) + :with (linear-sums + (,of (strides ,ten))) + :do (setf ,init (,@(if (symbolp func) + `(,func) + `(funcall ,funcsym)) ,init (t/store-ref ,type ,sto ,of))))) + ,init)))) diff --git a/src/sugar/seq.lisp b/src/special/seq.lisp similarity index 70% rename from src/sugar/seq.lisp rename to src/special/seq.lisp index 9c96efa..41ef589 100644 --- a/src/sugar/seq.lisp +++ b/src/special/seq.lisp @@ -27,22 +27,26 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package #:matlisp) -(defun arange (start end &optional (h 1d0)) +(defun range (start end &optional (h 1d0)) (let ((quo (ceiling (if (> start end) (- start end) (- end start)) h))) (if (= quo 0) nil - (let*-typed ((ret (real-typed-zeros (idxv quo)) :type real-tensor) - (sto-r (store ret) :type real-store-vector) - (h (coerce-real-unforgiving (if (> start end) (- h) h)) :type real-type)) - (loop :for i :from 0 :below quo - :for ori := (coerce-real-unforgiving start) :then (+ ori h) - :do (setf (aref sto-r i) ori)) - ret)))) + (let* ((ret (zeros quo 'real-tensor)) + (sto (store ret)) + (h (coerce (if (> start end) (- h) h) 'double-float))) + (declare (type (simple-array double-float (*)) sto) + (type double-float h)) + (very-quickly + (loop :for i :from 0 :below quo + :for ori := (coerce start 'double-float) :then (+ ori h) + :do (t/store-set real-tensor ori sto i))) + ret)))) -(defun alinspace (start end &optional (num-points (1+ (abs (- start end))))) - (let ((h (/ (- end start) (1- num-points)))) - (arange start (+ h end) (abs h)))) +(defun linspace (start end &optional (num-points (1+ (abs (- start end))))) + (let* ((num-points (floor num-points)) + (h (/ (- end start) (1- num-points)))) + (range start (+ h end) (abs h)))) -(defun range (start end &optional (h 1)) +(defun list-range (start end &optional (h 1)) (declare (type real start end h)) (let ((quo (ceiling (if (> start end) (- start end) (- end start)) h))) (if (= quo 0) nil @@ -51,6 +55,8 @@ :for ori := start :then (+ ori h) :collect ori))))) -(defun linspace (start end &optional (num-points (1+ (abs (- start end))))) - (let ((h (/ (- end start) (1- num-points)))) - (range start (+ h end) (abs h)))) +(defun list-linspace (start end &optional (num-points (1+ (abs (- start end))))) + (let* ((num-points (floor num-points)) + (h (/ (- end start) (1- num-points)))) + (list-range start (+ h end) (abs h)))) + diff --git a/src/utilities/lvec.lisp b/src/utilities/lvec.lisp index 3ab1918..5e81a47 100644 --- a/src/utilities/lvec.lisp +++ b/src/utilities/lvec.lisp @@ -5,7 +5,7 @@ (declare (type vector)) (loop :for i :of-type fixnum :from 0 :below (length vec) - :for ret = (aref vec 0) :then (funcall func (aref vec i) ret) + :for ret = (aref vec 0) :then (funcall func ret (aref vec i)) :finally (return ret))) (definline lvec-foldr (func vec) commit 6fb6102eb0a39b2bf48ba2dfbe98f2d7a1966935 Author: Akshay Srinivasan <aks...@gm...> Date: Thu Aug 22 21:58:42 2013 -0700 Cleaned up random. diff --git a/AUTHORS b/AUTHORS index 5f68edf..054d16e 100644 --- a/AUTHORS +++ b/AUTHORS @@ -9,3 +9,6 @@ Femlisp (www.femlisp.org); it has been used here The infix reader is modified and included here with the permission of its original author Mark Kantrowitz. + +The random number generators are borrowed and adapted from +cl-random written by Tamas Papp. \ No newline at end of file diff --git a/matlisp.asd b/matlisp.asd index cfb71d3..44384f4 100644 --- a/matlisp.asd +++ b/matlisp.asd @@ -165,6 +165,10 @@ :components ((:file "lu") (:file "chol") (:file "eig"))) + (:module "matlisp-special" + :pathname "special" + :depends-on ("matlisp-base" "matlisp-classes" "matlisp-level-1" "matlisp-level-2" "matlisp-level-3") + :components ((:file "random"))) #+nil (:module "matlisp-sugar" :pathname "sugar" diff --git a/src/packages/odepack/dlsode.lisp b/src/packages/odepack/dlsode.lisp index dab15bb..466603c 100644 --- a/src/packages/odepack/dlsode.lisp +++ b/src/packages/odepack/dlsode.lisp @@ -68,13 +68,12 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun pend-field (neq time y ydot) - (setf (fv-ref ydot 0) (fv-ref y 1) - (fv-ref ydot 1) (- (sin (fv-ref y 0))))) + (setf (fv-ref ydot 0) (fv-ref y 1) + (fv-ref ydot 1) (- (sin (fv-ref y 0))))) (defun pend-report (ts y) (format t "~A ~A ~A ~%" ts (aref y 0) (aref y 1))) - (defun pcart-field (neq time y ydot) (declare (ignore neq time)) (very-quickly diff --git a/src/level-1/random.lisp b/src/special/random.lisp similarity index 50% rename from src/level-1/random.lisp rename to src/special/random.lisp index 4bdf231..997d039 100644 --- a/src/level-1/random.lisp +++ b/src/special/random.lisp @@ -1,17 +1,18 @@ (in-package #:matlisp) -(declaim (inline draw-standard-exponential)) -(defun draw-standard-exponential () +(declaim (ftype (function () double-float) draw-standard-normal draw-standard-normal-marsaglia draw-standard-exponential)) + +(definline draw-standard-exponential () "Return a random variable from the Exponential(1) distribution, which has density exp(-x)." + ;; Adapted from cl-random, originally written by Tamas Papp ;; need 1-random, because there is a small but nonzero chance of getting a 0. (- (log (- 1d0 (random 1d0))))) -(declaim (ftype (function () double-float) draw-standard-normal-leva draw-standard-normal-marsaglia)) -(definline draw-standard-normal-leva () +(definline draw-standard-normal () "Draw a random number from N(0,1)." ;; Method from Leva (1992). This is considered much better/faster than the Box-Muller method. ;; Adapted from cl-random, originally written by Tamas Papp - ;; This tends to be just as fast as Marsaglia with storage. + ;; This seems to be just as fast as Marsaglia with storage. (very-quickly (loop :do (let* ((u (random 1d0)) @@ -43,25 +44,33 @@ (setf prev (* y mult)) (return (* x mult)))))))))) -;; -(defun randn (dims) - (let* ((ret (zeros dims 'real-tensor)) - (sto (store ret))) - (declare (type (simple-array double-float (*)) sto)) - (very-quickly - (mod-dotimes (idx (dimensions ret)) - :with (linear-sums - (of-ret (strides ret))) - :do (setf (aref sto of-ret) (the double-float (draw-standard-normal-leva))))) - ret)) +;; +(defmacro fill-tensor (type (func tensor)) + (using-gensyms (decl (tensor)) + (with-gensyms (sto ofst) + `(let* (,@decl + (,sto (store ,tensor))) + (declare (type ,type ,tensor) + (type ,(store-type type) ,sto)) + (very-quickly + (mod-dotimes (idx (dimensions ,tensor)) + :with (linear-sums + (,ofst (strides ,tensor))) + :do (t/store-set ,type ,(etypecase func (symbol `(,func)) (cons func)) ,sto ,ofst))) + ,tensor)))) + +(macrolet ((generate-rand (func clause) + (let ((clause (etypecase clause + (symbol `(,clause)) + (cons clause)))) + `(defun ,func (&optional dims) + (if dims + (fill-tensor real-tensor (,clause (zeros dims 'real-tensor))) + ,clause)))) + (generate-rands ((&rest args)) + `(progn + ,@(mapcar #'(lambda (x) `(generate-rand ,(car x) ,(cadr x))) args)))) + (generate-rands ((randn (draw-standard-normal)) + (rand (random 1d0)) + (rande (draw-standard-exponential))))) -(defun rand (dims) - (let* ((ret (zeros dims 'real-tensor)) - (sto (store ret))) - (declare (type (simple-array double-float (*)) sto)) - (very-quickly - (mod-dotimes (idx (dimensions ret)) - :with (linear-sums - (of-ret (strides ret))) - :do (setf (aref sto of-ret) (random 1d0)))) - ret)) commit 60f2b8490d5a31c90886c51d081bdb802f5431d6 Author: Akshay Srinivasan <aks...@gm...> Date: Wed Aug 21 19:50:19 2013 -0700 Made attribute hash-table allocation lazy. diff --git a/lib-src/gnuplot/gnuplot.lisp b/lib-src/gnuplot/gnuplot.lisp index 9bfaf56..d34a360 100644 --- a/lib-src/gnuplot/gnuplot.lisp +++ b/lib-src/gnuplot/gnuplot.lisp @@ -8,7 +8,7 @@ ccl:run-program gnuplot-binary nil :input :stream :wait nil :output t)) -(defun plot2d (data &key (color (list "#FF0000"))) +(defun gnuplot-send (str &rest args) (unless *current-gnuplot-process* (setf *current-gnuplot-process* (open-gnuplot-stream))) (let ((stream (#+:sbcl @@ -16,23 +16,16 @@ #+:ccl ccl:external-process-input-stream *current-gnuplot-process*))) - (with-open-file (s "/tmp/matlisp-gnuplot.out" :direction :output :if-exists :supersede :if-does-not-exist :create) - (loop :for i :from 0 :below (loop :for x :in data :minimizing (number-of-elements x)) - :do (loop :for x :in data :do (format s "~a " (tensor-ref x i)) :finally (format s "~%")))) - (format stream "plot '/tmp/matlisp-gnuplot.out' with lines linecolor rgb ~s~%" color) - (finish-output stream))) - -(defun gnuplot-send (str) - (unless *current-gnuplot-process* - (setf *current-gnuplot-process* (open-gnuplot-stream))) - (let ((stream (#+:sbcl - sb-ext:process-input - #+:ccl - ccl:external-process-input-stream - *current-gnuplot-process*))) - (format stream "~a~%" str) + (apply #'format (append (list stream str) args)) (finish-output stream))) +(defun plot2d (data &key (lines t) (color (list "#FF0000"))) + (with-open-file (s "/tmp/matlisp-gnuplot.out" :direction :output :if-exists :supersede :if-does-not-exist :create) + (loop :for i :from 0 :below (loop :for x :in data :minimizing (size x)) + :do (loop :for x :in data :do (format s "~a " (coerce (ref x i) 'single-float)) :finally (format s "~%")))) + (if lines + (gnuplot-send "plot '/tmp/matlisp-gnuplot.out' with lines linecolor rgb ~s~%" color) + (gnuplot-send "plot '/tmp/matlisp-gnuplot.out'~%"))) ;; (defclass gnuplot-plot-info () ;; ((title diff --git a/src/base/standard-tensor.lisp b/src/base/standard-tensor.lisp index c34ed6d..426536f 100644 --- a/src/base/standard-tensor.lisp +++ b/src/base/standard-tensor.lisp @@ -58,10 +58,22 @@ (store :initarg :store :reader store :documentation "The actual storage for the tensor.") ;; - (attributes :initarg :attributes :reader attributes :initform (make-hash-table) + (attributes :initarg :attributes :initform nil :documentation "Place for computable attributes of an object instance.")) (:documentation "Basic tensor class.")) +;;Create hash-table only when necessary +(definline attributes (x) + (declare (type standard-tensor x)) + (or (slot-value x 'attributes) + (let ((htbl (make-hash-table))) + (setf (slot-value x 'attributes) htbl) + htbl))) + +(declaim (ftype (function (standard-tensor) index-store-vector) strides dimensions) + (ftype (function (standard-tensor) index-type) head) + (ftype (function (standard-tensor) hash-table) attributes)) + (defmacro memoizing ((tensor name) &rest body) (declare (type symbol name)) (with-gensyms (tens) @@ -95,6 +107,7 @@ (declare (type standard-tensor tensor)) (lvec-foldr #'* (the index-store-vector (dimensions tensor)))) +;; (defgeneric store-size (tensor) (:documentation " Syntax @@ -424,3 +437,14 @@ :strides (very-quickly (vectorify (the index-store-vector nstds) nrank 'index-type)) :store (store tensor) :parent-tensor tensor))))))) + +(definline slice~ (x axis &optional (idx 0)) + (let ((slst (make-list (rank x) :initial-element '(* * *)))) + (rplaca (nthcdr axis slst) (list idx '* (1+ idx))) + (sub-tensor~ x slst nil))) + +(definline row-slice~ (x idx) + (slice~ x 0 idx)) + +(definline col-slice~ (x idx) + (slice~ x 1 idx)) diff --git a/src/level-1/map.lisp b/src/level-1/map.lisp new file mode 100644 index 0000000..3359ea9 --- /dev/null +++ b/src/level-1/map.lisp @@ -0,0 +1,72 @@ +(in-package #:matlisp) + +(defgeneric mapsor! (func x y) + (:documentation " + y <- func(x) +") + (:method :before ((func function) (x standard-tensor) (y standard-tensor)) + (assert (very-quickly (lvec-eq (dimensions x) (dimensions y))) nil 'tensor-dimension-mismatch))) + +(defmethod mapsor! ((func function) (x standard-tensor) (y standard-tensor)) + (let ((clx (class-name (class-of x))) + (cly (class-name (class-of y)))) + (assert (and + (member clx *tensor-type-leaves*) + (member cly *tensor-type-leaves*)) + nil 'tensor-abstract-class :tensor-class (list clx cly)) + (compile-and-eval + `(defmethod mapsor! ((func function) (x ,clx) (y ,cly)) + (let ((sto-x (store x)) + (sto-y (store y))) + (declare (type ,(store-type clx) sto-x) + (type ,(store-type cly) sto-y)) + (very-quickly + (mod-dotimes (idx (dimensions x)) + :with (linear-sums + (of-x (strides x)) + (of-y (strides y))) + :do (t/store-set ,cly (funcall func (t/store-ref ,clx sto-x of-x)) sto-y of-y)))) + y))) + (mapsor! func x y)) + +(defun mapcol (func x &optional (axis 1)) + (declare (type standard-tensor x)) + (assert (tensor-matrixp x) nil 'tensor-dimension-mismatch) + (let* ((v-x (slice~ x axis)) + (st-x (aref (the index-store-vector (strides x)) axis)) + (ret (zeros (aref (the index-store-vector (dimensions x)) axis) (class-of x)))) + (loop :for i :from 0 :below (aref (the index-store-vector (dimensions x)) axis) + :do (progn + (setf (ref ret i) (funcall func v-x)) + (incf (slot-value v-x 'head) st-x))) + ret)) + +(defun tensor-min (x) + (let ((min nil)) + (mod-dotimes (idx (dimensions x)) + :do (when (or (null min) (< (ref x idx) min)) + (setf min (ref x idx)))) + min)) + +(defun idx-min (v) + (let ((min-idx nil) + (min nil)) + (loop :for i :from 0 :below (aref (the index-store-vector (dimensions v)) 0) + :do (when (or (null min) (< (ref v i) min)) + (setf min-idx i + min (ref v i)))) + (values min-idx min))) + +(defun mapxis! (func x y &optional (axis 0)) + (declare (type standard-tensor x y)) + (multiple-value-bind (view-x view-y) (let ((slst (make-list (rank x) :initial-element '(* * *)))) + (rplaca (nthcdr axis slst) (list 0 '* 1)) + (values (sub-tensor~ x slst nil) (sub-tensor~ y slst nil))) + (let ((st-x (aref (the index-store-vector (dimensions x)) axis)) + (st-y (aref (the index-store-vector (dimensions x)) axis))) + (loop :for i :from 0 :below (aref (the index-store-vector (dimensions x)) axis) + :do (progn + ;;May die if you're doing fancy stuff. + (funcall func view-x view-y) + + diff --git a/src/level-1/random.lisp b/src/level-1/random.lisp new file mode 100644 index 0000000..4bdf231 --- /dev/null +++ b/src/level-1/random.lisp @@ -0,0 +1,67 @@ +(in-package #:matlisp) + +(declaim (inline draw-standard-exponential)) +(defun draw-standard-exponential () + "Return a random variable from the Exponential(1) distribution, which has density exp(-x)." + ;; need 1-random, because there is a small but nonzero chance of getting a 0. + (- (log (- 1d0 (random 1d0))))) + +(declaim (ftype (function () double-float) draw-standard-normal-leva draw-standard-normal-marsaglia)) +(definline draw-standard-normal-leva () + "Draw a random number from N(0,1)." + ;; Method from Leva (1992). This is considered much better/faster than the Box-Muller method. + ;; Adapted from cl-random, originally written by Tamas Papp + ;; This tends to be just as fast as Marsaglia with storage. + (very-quickly + (loop + :do (let* ((u (random 1d0)) + (v (* 1.7156d0 (- (random 1d0) 0.5d0))) + (x (- u 0.449871d0)) + (y (+ (abs v) 0.386595d0)) + (q (+ (expt x 2) (* y (- (* 0.19600d0 y) (* 0.25472d0 x)))))) + (declare (type double-float u v x y q)) + (unless (and (> q 0.27597d0) + (or (> q 0.27846d0) + (plusp (+ (expt v 2) (* 4 (expt u 2) (log u)))))) + (return (/ v u))))))) + +;;Not thread safe, obviously +(let ((prev nil)) + (defun draw-standard-normal-marsaglia () + (if prev + (prog1 prev + (setf prev nil)) + (very-quickly + (loop + :do (let* ((x (1- (random 2d0))) + (y (1- (random 2d0))) + (s (+ (* x x) (* y y)))) + (declare (type double-float x y s)) + (when (<= s 1d0) + (let ((mult (sqrt (/ (* -2 (log s)) s)))) + (declare (type double-float mult)) + (setf prev (* y mult)) + (return (* x mult)))))))))) + +;; +(defun randn (dims) + (let* ((ret (zeros dims 'real-tensor)) + (sto (store ret))) + (declare (type (simple-array double-float (*)) sto)) + (very-quickly + (mod-dotimes (idx (dimensions ret)) + :with (linear-sums + (of-ret (strides ret))) + :do (setf (aref sto of-ret) (the double-float (draw-standard-normal-leva))))) + ret)) + +(defun rand (dims) + (let* ((ret (zeros dims 'real-tensor)) + (sto (store ret))) + (declare (type (simple-array double-float (*)) sto)) + (very-quickly + (mod-dotimes (idx (dimensions ret)) + :with (linear-sums + (of-ret (strides ret))) + :do (setf (aref sto of-ret) (random 1d0)))) + ret)) commit 050548a939e93208a4990b6de248e3e39b3caa45 Author: Akshay Srinivasan <aks...@gm...> Date: Tue Aug 20 01:21:26 2013 -0700 Added sum method. Made changes to dot. diff --git a/matlisp.asd b/matlisp.asd index f3c236b..cfb71d3 100644 --- a/matlisp.asd +++ b/matlisp.asd @@ -148,7 +148,9 @@ (:file "realimag" :depends-on ("copy")) (:file "trans" - :depends-on ("scal" "copy")))) + :depends-on ("scal" "copy")) + (:file "sum" + :depends-on ("dot" "copy")))) (:module "matlisp-level-2" :pathname "level-2" :depends-on ("matlisp-base" "matlisp-classes" "foreign-core" "matlisp-level-1") diff --git a/src/level-1/dot.lisp b/src/level-1/dot.lisp index 354c271..3a81f7e 100644 --- a/src/level-1/dot.lisp +++ b/src/level-1/dot.lisp @@ -34,41 +34,48 @@ (if conjp 'zdotc 'zdotu)) ;; -(deft/generic (t/blas-dot #'subtypep) sym (x y &optional conjp)) -(deft/method t/blas-dot (sym blas-numeric-tensor) (x y &optional (conjp t)) - (using-gensyms (decl (x y)) - `(let (,@decl) - (declare (type ,sym ,x ,y)) - (,(macroexpand-1 `(t/blas-dot-func ,sym ,conjp)) - (aref (the index-store-vector (dimensions ,x)) 0) - (the ,(store-type sym) (store ,x)) (aref (the index-store-vector (strides ,x)) 0) - (the ,(store-type sym) (store ,y)) (aref (the index-store-vector (strides ,y)) 0) - (head ,x) (head ,y))))) +(deft/generic (t/blas-dot #'subtypep) sym (x y &optional conjp num-y?)) +(deft/method t/blas-dot (sym blas-numeric-tensor) (x y &optional (conjp t) (num-y? nil)) + (using-gensyms (decl (x y)) + (with-gensyms (sto) + `(let (,@decl + ,@(when num-y? `((,sto (t/store-allocator ,sym 1))))) + (declare (type ,sym ,x ,@(unless num-y? `(,y))) + ,@(when num-y? `((type ,(field-type sym) ,y) + (type ,(store-type sym) ,sto)))) + ,@(when num-y? `((t/store-set ,sym ,y ,sto 0))) + (,(macroexpand-1 `(t/blas-dot-func ,sym ,conjp)) + (aref (the index-store-vector (dimensions ,x)) 0) + (the ,(store-type sym) (store ,x)) (aref (the index-store-vector (strides ,x)) 0) + (the ,(store-type sym) ,(if num-y? sto `(store ,y))) ,(if num-y? 0 `(aref (the index-store-vector (strides ,y)) 0)) + (head ,x) ,(if num-y? 0 `(head ,y))))))) -(deft/generic (t/dot #'subtypep) sym (x y &optional conjp)) -(deft/method t/dot (sym standard-tensor) (x y &optional (conjp t)) +(deft/generic (t/dot #'subtypep) sym (x y &optional conjp num-y?)) +(deft/method t/dot (sym standard-tensor) (x y &optional (conjp t) (num-y? nil)) (using-gensyms (decl (x y)) (with-gensyms (sto-x sto-y of-x of-y stp-x stp-y dot) `(let (,@decl) - (declare (type ,sym ,x ,y)) + (declare (type ,sym ,x ,@(unless num-y? `(,y))) + ,@(when num-y? `((type ,(field-type sym) ,y)))) (let ((,sto-x (store ,x)) (,stp-x (aref (the index-store-vector (strides ,x)) 0)) (,of-x (head ,x)) - (,sto-y (store ,y)) - (,stp-y (aref (the index-store-vector (strides ,y)) 0)) - (,of-y (head ,y)) + ,@(unless num-y? + `((,sto-y (store ,y)) + (,stp-y (aref (the index-store-vector (strides ,y)) 0)) + (,of-y (head ,y)))) (,dot (t/fid+ ,(field-type sym)))) - (declare (type ,(store-type sym) ,sto-x ,sto-y) - (type index-type ,stp-x ,stp-y ,of-x ,of-y) + (declare (type ,(store-type sym) ,sto-x ,@(unless `(,sto-y))) + (type index-type ,stp-x ,of-x ,@(unless num-y? `(,stp-y ,of-y))) (type ,(field-type sym) ,dot)) (very-quickly (loop :repeat (aref (the index-store-vector (dimensions ,x)) 0) :do (setf ,dot (t/f+ ,(field-type sym) ,dot (t/f* ,(field-type sym) ,(recursive-append (when conjp `(t/fc ,(field-type sym))) `(t/store-ref ,sym ,sto-x ,of-x)) - (t/store-ref ,sym ,sto-y ,of-y))) + ,(if num-y? y `(t/store-ref ,sym ,sto-y ,of-y)))) ,of-x (+ ,of-x ,stp-x) - ,of-y (+ ,of-y ,stp-y)))) + ,@(unless num-y? `(,of-y (+ ,of-y ,stp-y)))))) ,dot))))) ;;---------------------------------------------------------------;; (defgeneric dot (x y &optional conjugate-p) @@ -133,3 +140,24 @@ (dot x y conjugate-p)) (t (error "Don't know how to compute the dot product of ~a , ~a." clx cly))))) + +(defmethod dot ((x standard-tensor) (y t) &optional (conjugate-p t)) + (let ((clx (class-name (class-of x)))) + (assert (member clx *tensor-type-leaves*) + nil 'tensor-abstract-class :tensor-class (list clx)) + (compile-and-eval + `(defmethod dot ((x ,clx) (y t) &optional (conjugate-p t)) + (let ((y (t/coerce ,(field-type clx) y))) + (declare (type ,(field-type clx) y)) + ,(recursive-append + (when (subtypep clx 'blas-numeric-tensor) + `(if (call-fortran? x (t/l1-lb ,clx)) + (if conjugate-p + (t/blas-dot ,clx x y t t) + (t/blas-dot ,clx x y nil t)))) + `(if conjugate-p + ;;Please do your checks before coming here. + (t/dot ,clx x y t t) + (t/dot ,clx x y nil t)))))) + (dot x y conjugate-p))) + diff --git a/src/level-1/sum.lisp b/src/level-1/sum.lisp new file mode 100644 index 0000000..dc6dada --- /dev/null +++ b/src/level-1/sum.lisp @@ -0,0 +1,65 @@ +(in-package #:matlisp) + +(deft/generic (t/sum #'subtypep) sym (x ret &optional axis)) +(deft/method t/sum (sym standard-tensor) (x ret &optional (axis 0)) + (if (null ret) + `(dot ,x (t/fid* ,(field-type sym)) nil) + (using-gensyms (decl (x axis ret)) + (with-gensyms (view argstd) + `(let* (,@decl) + (declare (type ,sym ,x ,ret) + (type index-type ,axis)) + (let ((,view (let ((slst (make-list (rank ,x) :initial-element '(* * *)))) + (rplaca (nthcdr ,axis slst) (list 0 '* 1)) + (sub-tensor~ ,x slst nil))) + (,argstd (aref (the index-store-vector (strides ,x)) ,axis))) + (declare (type ,sym ,view) + (type index-type ,argstd)) + (loop :for i :from 0 :below (aref (the index-store-vector (dimensions ,x)) ,axis) + :do (progn + (axpy! (t/fid* ,(field-type sym)) ,view ,ret) + (incf (slot-value ,view 'head) ,argstd))) + ,ret)))))) + +(defgeneric sum! (x y &optional axis) + (:documentation " + (SUM! x y [axis 0]) + + -- + y <- \ x(:, : ..., i, :, :..) + /_ + i + where the index to be summed over is chosen using @arg{axis}. +") + (:method :before ((x standard-tensor) (y standard-tensor) &optional (axis 0)) + (assert (and + (= (1- (rank x)) (rank y)) + (let ((dims-x (dimensions x)) + (dims-y (dimensions y))) + (declare (type index-store-vector dims-x dims-y)) + (loop + :for i :from 0 :below (rank x) + :and j := 0 :then (if (= i axis) j (1+ j)) + :do (unless (or (= i axis) (= (aref dims-x i) (aref dims-y j))) + (return nil)) + :finally (return t)))) + nil 'tensor-dimension-mismatch)) + (:method :before ((x standard-tensor) (y (eql nil)) &optional (axis 0)) + (declare (ignore axis)) + (assert (tensor-vectorp x) nil 'tensor-dimension-mismatch))) + +(defmethod sum! ((x standard-tensor) (y t) &optional (axis 0)) + (let ((clx (class-name (class-of x)))) + (assert (member clx *tensor-type-leaves*) + nil 'tensor-abstract-class :tensor-class (list clx)) + (compile-and-eval + `(progn + (defmethod sum! ((x ,clx) (y ,clx) &optional (axis 0)) + (t/sum ,clx x y axis)) + (defmethod sum! ((x ,clx) (y (eql nil)) &optional (axis 0)) + (declare (ignore axis)) + (t/sum ,clx x nil)))) + (sum! x y axis))) + + + commit 7aa696273c37819ebc5b9ee1040d0f194dd8145a Author: Akshay Srinivasan <aks...@gm...> Date: Mon Aug 19 20:19:10 2013 -0700 Removed the old loopy file. diff --git a/src/old/loopy-old.lisp b/src/old/loopy-old.lisp deleted file mode 100644 index 008dcd2..0000000 --- a/src/old/loopy-old.lisp +++ /dev/null @@ -1,118 +0,0 @@ -;;Very ugly inflexible code; get rid of this in some time or make use of mod-dotimes. -(defmacro mod-loop ((idx dims) &body body) - (check-type idx symbol) - (let ((tensor-table (make-hash-table))) - (labels ((get-tensors (decl) - (if (null decl) t - (let ((cdecl (car decl))) - (when (and (eq (first cdecl) 'type) - (get-tensor-class-optimization (second cdecl))) - (dolist (sym (cddr cdecl)) - (let ((hsh (list - :class (second cdecl) - :stride-sym (gensym (string+ (symbol-name sym) "-stride")) - :store-sym (gensym (string+ (symbol-name sym) "-store")) - :offset-sym (gensym (string+ (symbol-name sym) "-offset")) - :ref-count 0))) - (setf (gethash sym tensor-table) hsh)))) - (get-tensors (cdr decl))))) - (ttrans-p (code) - (and (consp code) (eq (first code) 'tensor-ref) - (gethash (second code) tensor-table) - (eq (third code) idx))) - (incref (ten) - (incf (getf (gethash ten tensor-table) :ref-count))) - (transform-setf-tensor-ref (snippet ret) - (if (null snippet) ret - (transform-setf-tensor-ref - (cddr snippet) - (append ret - (destructuring-bind (to from &rest rest) snippet - (declare (ignore rest)) - (let ((to-t? (ttrans-p to)) - (fr-t? (ttrans-p from))) - (cond - ((and to-t? fr-t?) - (let ((to-opt (gethash (second to) tensor-table)) - (fr-opt (gethash (second from) tensor-table))) - (if (eq (second (multiple-value-list (get-tensor-class-optimization (getf to-opt :class)))) - (second (multiple-value-list (get-tensor-class-optimization (getf fr-opt :class))))) - (progn - (incref (second to)) (incref (second from)) - (cdr (funcall (getf (get-tensor-class-optimization (getf to-opt :class)) :reader-writer) - (getf fr-opt :store-sym) (getf fr-opt :offset-sym) (getf to-opt :store-sym) (getf to-opt :offset-sym)))) - (list to (find-tensor-refs from nil))))) - (to-t? - (incref (second to)) - (let ((to-opt (gethash (second to) tensor-table))) - ;;Add type checking here! - (cdr (funcall (getf (get-tensor-class-optimization (getf to-opt :class)) :value-writer) - (find-tensor-refs from nil) (getf to-opt :store-sym) (getf to-opt :offset-sym))))) - (t - (list to (find-tensor-refs from nil)))))))))) - (transform-tensor-ref (snippet) - (if (eq (first snippet) 'setf) - (cons 'setf (transform-setf-tensor-ref (cdr snippet) nil)) - (destructuring-bind (tref ten index) snippet - (assert (eq tref 'tensor-ref)) - (let ((topt (gethash ten tensor-table))) - (if (not (and (eq index idx) topt)) snippet - (progn - (incref ten) - (funcall (getf (get-tensor-class-optimization (getf topt :class)) :reader) (getf topt :store-sym) (getf topt :offset-sym)))))))) - (find-tensor-refs (code ret) - (if (null code) (reverse ret) - (cond - ((consp code) - (if (member (first code) '(tensor-ref setf)) - (transform-tensor-ref code) - (find-tensor-refs (cdr code) (cons (find-tensor-refs (car code) nil) ret)))) - (t code))))) - ;; - (when (eq (caar body) 'declare) - (get-tensors (cdar body))) - (let ((tr-body (find-tensor-refs body nil))) - (with-gensyms (dims-sym rank-sym count-sym) - `(let* ((,dims-sym ,dims) - (,rank-sym (length ,dims-sym)) - (,idx (allocate-index-store ,rank-sym)) - ,@(loop for key being the hash-keys of tensor-table - when (> (getf (gethash key tensor-table) :ref-count) 0) - collect (let ((hsh (gethash key tensor-table))) - `(,(getf hsh :stride-sym) (strides ,key)))) - ,@(loop for key being the hash-keys of tensor-table - when (> (getf (gethash key tensor-table) :ref-count) 0) - collect (let ((hsh (gethash key tensor-table))) - `(,(getf hsh :store-sym) (store ,key))))) - (declare (type (index-array *) ,idx ,@(loop for key being the hash-keys of tensor-table - when (> (getf (gethash key tensor-table) :ref-count) 0) - collect (getf (gethash key tensor-table) :stride-sym))) - ,@(loop for key being the hash-keys of tensor-table - when (> (getf (gethash key tensor-table) :ref-count) 0) - collect (let* ((hsh (gethash key tensor-table)) - (opt (get-tensor-class-optimization (getf hsh :class)))) - `(type ,(linear-array-type (getf opt :store-type)) ,(getf hsh :store-sym))))) - (loop - ,@(loop for key being the hash-keys of tensor-table - when (> (getf (gethash key tensor-table) :ref-count) 0) - append (let ((hsh (gethash key tensor-table))) - `(with ,(getf hsh :offset-sym) of-type index-type = (head ,key)))) - do (locally - ,@tr-body) - ;;Optimized for row-order - while (loop for ,count-sym of-type index-type from (1- ,rank-sym) downto 0 - do (if (= (aref ,idx ,count-sym) (1- (aref ,dims-sym ,count-sym))) - (progn - (setf (aref ,idx ,count-sym) 0) - ,@(loop for key being the hash-keys of tensor-table - when (> (getf (gethash key tensor-table) :ref-count) 0) - collect (let ((hsh (gethash key tensor-table))) - `(decf ,(getf hsh :offset-sym) (* (aref ,(getf hsh :stride-sym) ,count-sym) (1- (aref ,dims-sym ,count-sym))))))) - (progn - (incf (aref ,idx ,count-sym)) - ,@(loop for key being the hash-keys of tensor-table - when (> (getf (gethash key tensor-table) :ref-count) 0) - collect (let ((hsh (gethash key tensor-table))) - `(incf ,(getf hsh :offset-sym) (aref ,(getf hsh :stride-sym) ,count-sym)))) - (return t))) - finally (return nil))))))))) commit 570ae7eb80324580ee27cfa7ba1d20b11f779e41 Author: Akshay Srinivasan <ak...@cs...> Date: Mon Aug 19 15:48:54 2013 -0700 Minor fix to copy! diff --git a/matlisp.asd b/matlisp.asd index f5290e8..f3c236b 100644 --- a/matlisp.asd +++ b/matlisp.asd @@ -161,7 +161,8 @@ :pathname "lapack" :depends-on ("matlisp-base" "matlisp-classes" "matlisp-level-1" "matlisp-level-2" "matlisp-level-3") :components ((:file "lu") - (:file "chol"))) + (:file "chol") + (:file "eig"))) #+nil (:module "matlisp-sugar" :pathname "sugar" diff --git a/src/level-1/copy.lisp b/src/level-1/copy.lisp index 0d71f6d..f7432f7 100644 --- a/src/level-1/copy.lisp +++ b/src/level-1/copy.lisp @@ -157,7 +157,7 @@ ,(recursive-append (when (subtypep cly 'blas-numeric-tensor) `(if-let (strd (and (call-fortran? y (t/l1-lb ,cly)) (consecutive-storep y))) - (t/blas-copy! ,cly x nil y strd))) + (t/blas-copy! ,cly (t/coerce ,(field-type cly) x) nil y strd))) `(t/copy! (t ,cly) x y)))) (copy! x y))) commit 79a87b8605dba8ae97c8f354e42f1f081b127771 Author: Akshay Srinivasan <aks...@gm...> Date: Mon Aug 19 09:52:54 2013 -0700 Not calling geev for workspace size, does not seem to save much time. diff --git a/src/lapack/eig.lisp b/src/lapack/eig.lisp index a907a7b..923aee7 100644 --- a/src/lapack/eig.lisp +++ b/src/lapack/eig.lisp @@ -52,6 +52,12 @@ (deft/generic (t/lapack-geev-workspace-inquiry #'subtypep) sym (n jobvl jobvr)) +#+nil +(deft/method t/lapack-geev-workspace-inquiry (sym blas-numeric-tensor) (n jobvl jobvr) + (with-gensyms (n-sym) + `(let ((,n-sym ,n)) + (* 10 ,n-sym)))) + (deft/method t/lapack-geev-workspace-inquiry (sym blas-numeric-tensor) (n jobvl jobvr) (using-gensyms (decl (n jobvl jobvr)) (with-gensyms (xxx) commit fc524fd099c95abfc3af0280e8a200e461cc9493 Author: Akshay Srinivasan <aks...@gm...> Date: Mon Aug 19 01:08:50 2013 -0700 Ported geev diff --git a/src/base/template.lisp b/src/base/template.lisp index 8ae4dc3..cd7daf8 100644 --- a/src/base/template.lisp +++ b/src/base/template.lisp @@ -39,8 +39,10 @@ (with-gensyms (num-sym) `(let ((,num-sym ,num)) (cl:conjugate ,num-sym)))) + (deft/method t/fc (ty real) (num) num) + (defgeneric fc (x) (:method ((x complex)) (cl:conjugate x)) @@ -55,6 +57,26 @@ (defun field-realp (fil) (eql (macroexpand-1 `(t/fc ,fil phi)) 'phi)) ;; +(deft/generic (t/frealpart #'subtypep) ty (num)) + +(deft/method t/frealpart (ty number) (num) + (with-gensyms (num-sym) + `(let ((,num-sym ,num)) + (cl:realpart ,num-sym)))) + +(deft/method t/frealpart (ty real) (num) + num) +;; +(deft/generic (t/fimagpart #'subtypep) ty (num)) + +(deft/method t/fimagpart (ty number) (num) + (with-gensyms (num-sym) + `(let ((,num-sym ,num)) + (cl:imagpart ,num-sym)))) + +(deft/method t/fimagpart (ty real) (num) + `(t/fid+ ,ty)) +;; (deft/generic (t/f= #'subtypep) ty (&rest nums)) (deft/method t/f= (ty number) (&rest nums) (let* ((decl (zipsym nums)) diff --git a/src/foreign-core/lapack.lisp b/src/foreign-core/lapack.lisp index 0806287..b587e50 100644 --- a/src/foreign-core/lapack.lisp +++ b/src/foreign-core/lapack.lisp @@ -717,7 +717,7 @@ (ldvr :integer :input) (work (* :complex-double-float) :workspace-output) (lwork :integer :input) - (rwork (* :double-float) :workspace) + (rwork (* :double-float) :workspace-output) (info :integer :output) ) diff --git a/src/lapack/eig.lisp b/src/lapack/eig.lisp index 308204a..a907a7b 100644 --- a/src/lapack/eig.lisp +++ b/src/lapack/eig.lisp @@ -50,6 +50,30 @@ (the index-type (head ,A)) (if ,vl (the index-type (head ,vl)) 0) (if ,vr (the index-type (head ,vr)) 0))))) ;; +(deft/generic (t/lapack-geev-workspace-inquiry #'subtypep) sym (n jobvl jobvr)) + +(deft/method t/lapack-geev-workspace-inquiry (sym blas-numeric-tensor) (n jobvl jobvr) + (using-gensyms (decl (n jobvl jobvr)) + (with-gensyms (xxx) + `(let (,@decl + (,xxx (t/store-allocator ,sym 1))) + (declare (type index-type ,n) + (type character ,jobvl ,jobvr) + (type ,(store-type sym) ,xxx)) + (,(macroexpand-1 `(t/lapack-geev-func ,sym)) + ,jobvl ,jobvr + ,n + ,xxx ,n + ,xxx ,xxx + ,xxx ,n + ,xxx ,n + ,xxx -1 + 0) + (ceiling (t/frealpart ,(field-type sym) (t/store-ref ,sym ,xxx 0))))))) + +#+nil +(t/lapack-geev-workspace-inquiry complex-tensor 2 #\V #\V) + ;; #+nil (progn @@ -122,6 +146,49 @@ [3] INFO where INFO is T if successful, NIL otherwise. -")) - - +") + (:method :before ((a standard-tensor) &optional vl vr) + (assert (tensor-squarep a) nil 'tensor-dimension-mismatch) + (when vl + (assert (and (tensor-squarep vl) (= (nrows vl) (nrows a)) (typep vl (type-of a))) nil 'tensor-dimension-mismatch)) + (when vr + (assert (and (tensor-squarep vr) (= (nrows vr) (nrows a)) (typep vr (type-of a))) nil 'tensor-dimension-mismatch)))) + +(defmethod geev! ((a blas-numeric-tensor) &optional vl vr) + (let ((cla (class-name (class-of A)))) + (assert (member cla *tensor-type-leaves*) + nil 'tensor-abstract-class :tensor-class (list cla)) + (compile-and-eval + `(defmethod geev! ((A ,cla) &optional vl vr) + (let* ((n (nrows A)) + (jobvl (if vl #\V #\N)) + (jobvr (if vr #\V #\N)) + (work (t/store-allocator ,cla (t/lapack-geev-workspace-inquiry ,cla n jobvl jobvr))) + (wr (t/store-allocator ,cla n)) + (wi (t/store-allocator ,cla n))) + (ecase jobvl + ,@(loop :for jvl :in '(#\N #\V) + :collect `(,jvl + (ecase jobvr + ,@(loop :for jvr :in '(#\N #\V) + :collect `(,jvr + (with-columnification (,cla () (A ,@(when (char= jvl #\V) `(vl)) ,@(when (char= jvr #\V) `(vr)))) + (multiple-value-bind (osto owr owi ovl ovr owork info) + (t/lapack-geev! ,cla + A (or (blas-matrix-compatiblep A #\N) 0) + ,@(if (char= jvl #\N) `(nil 1) `(vl (or (blas-matrix-compatiblep vl #\N) 0))) + ,@(if (char= jvr #\N) `(nil 1) `(vr (or (blas-matrix-compatiblep vr #\N) 0))) + wr wi work) + (declare (ignore osto owr owi ovl ovr owork)) + (unless (= info 0) + (error "geev returned ~a~%" info)))))))))) + (values-list (remove-if #'null + (list + (let ((*check-after-initializing?* nil)) + (make-instance 'complex-tensor ;',(complexified-type cla) + :dimensions (make-index-store (list (nrows A))) + :strides (make-index-store (list 1)) + :head 0 + :store (t/geev-output-fix ,cla wr wi))) + vl vr))))))) + (geev! A vl vr)) diff --git a/src/lapack/geev.lisp b/src/lapack/geev.lisp index 531b004..9789585 100644 --- a/src/lapack/geev.lisp +++ b/src/lapack/geev.lisp @@ -372,11 +372,9 @@ (:nn (values "N" "N")) ((:vn t) (values "N" "V")) (:nv (values "V" "N")) - (:vv (values "V" "V"))) - + (:vv (values "V" "V"))) (let* ((ldvr (if (equal jobvr "V") n 1)) (ldvl (if (equal jobvl "V") n 1))) - (multiple-value-bind (store-a store-w store-vl store-vr work info) (zgeev jobvl jobvr commit a3ea5898fd82c16b66bf0ce3d5615e370deb40a8 Author: Akshay Srinivasan <aks...@gm...> Date: Sun Aug 18 23:32:53 2013 -0700 Saving state on geev porting. diff --git a/src/base/template.lisp b/src/base/template.lisp index f5d7fb3..8ae4dc3 100644 --- a/src/base/template.lisp +++ b/src/base/template.lisp @@ -86,6 +86,16 @@ (defun field-type (clname) (macroexpand-1 `(t/field-type ,clname))) +;;Hack? Yes. +(defun complexified-type (ten) + (let ((ty (macroexpand-1 `(t/field-type ,ten)))) + (if (subtypep ty 'complex) ten + (let* ((cty `(complex ,ty)) + (table-entry (or (gethash 't/field-type matlisp-template::*template-table*) (ERROR "Undefined template : ~a~%" 'T/FIELD-TYPE)))) + (car (find cty (mapcar #'(lambda (x) (list (cadr x) (funcall (car x) (cadr x)))) + (getf table-entry :methods)) + :key #'second :test #'list-eq)))))) + ;;Beware of infinite loops here. (deft/generic (t/store-element-type #'subtypep) sym ()) (deft/method t/store-element-type (sym standard-tensor) () diff --git a/src/lapack/eig.lisp b/src/lapack/eig.lisp new file mode 100644 index 0000000..308204a --- /dev/null +++ b/src/lapack/eig.lisp @@ -0,0 +1,127 @@ +(in-package #:matlisp) + +(deft/generic (t/lapack-geev-func #'subtypep) sym ()) + +(deft/method t/lapack-geev-func (sym real-tensor) () + 'dgeev) +;;Make API for real and complex versions similar. +(definline mzgeev (jobvl jobvr n a lda w rwork vl ldvl vr ldvr work lwork info &optional (head-a 0) (head-vl 0) (head-vr 0)) + (zgeev jobvl jobvr n a lda w vl ldvl vr ldvr work lwork rwork info head-a head-vl head-vr)) +(deft/method t/lapack-geev-func (sym complex-tensor) () + 'mzgeev) +;; +(deft/generic (t/geev-output-fix #'subtypep) sym (wr wi)) +(deft/method t/geev-output-fix (sym real-numeric-tensor) (wr wi) + (let ((csym (or (complexified-type sym) (error "No corresponding complex-tensor defined for type ~a." sym)))) + (using-gensyms (decl (wr wi)) + (with-gensyms (ret i) + `(let* (,@decl + (,ret (t/store-allocator ,csym (length ,wr)))) + (declare (type ,(store-type sym) ,wr ,wi) + (type ,(store-type csym) ,ret)) + (very-quickly + (loop :for ,i :from 0 :below (length ,wr) + :do (t/store-set ,csym (complex (aref ,wr ,i) (aref ,wi ,i)) ,ret ,i))) + ,ret))))) + +(deft/method t/geev-output-fix (sym complex-numeric-tensor) (wr wi) + (using-gensyms (decl (wr)) + `(let (,@decl) + (declare (type ,(store-type sym) ,wr)) + ,wr))) +;; +(deft/generic (t/lapack-geev! #'subtypep) sym (A lda vl ldvl vr ldvr wr wi work)) + +(deft/method t/lapack-geev! (sym blas-numeric-tensor) (A lda vl ldvl vr ldvr wr wi work) + (using-gensyms (decl (A lda vl ldvl vr ldvr wr wi work)) + `(let (,@decl) + (declare (type ,sym ,A) + (type index-type ,lda) + (type ,(store-type sym) ,wr ,wi ,work)) + (,(macroexpand-1 `(t/lapack-geev-func ,sym)) + (if ,vl #\V #\N) (if ,vr #\V #\N) + (nrows ,A) + (the ,(store-type sym) (store ,A)) ,lda + ,wr ,wi + (if ,vl (the ,(store-type sym) (store ,vl)) (cffi:null-pointer)) (if ,vl ,ldvl 1) + (if ,vr (the ,(store-type sym) (store ,vr)) (cffi:null-pointer)) (if ,vr ,ldvr 1) + ,work (length ,work) + 0 + (the index-type (head ,A)) (if ,vl (the index-type (head ,vl)) 0) (if ,vr (the index-type (head ,vr)) 0))))) +;; + +;; +#+nil +(progn +(let ((*default-tensor-type* 'complex-tensor)) + (let ((a (copy! #2a((1 2) (3 4)) (zeros '(2 2))))) + (t/lapack-geev! complex-tensor a 2 (zeros '(2 2)) 2 (zeros '(2 2)) 2 (t/store-allocator complex-tensor 2) (t/store-allocator complex-tensor 2) (t/store-allocator complex-tensor 100)))) + + +(let ((a (copy! #2a((1 2) (3 4)) (zeros '(2 2))))) + (t/lapack-geev! real-tensor a 2 nil 1 nil 1 (t/store-allocator real-tensor 2) (t/store-allocator real-tensor 2) (t/store-allocator real-tensor 100))) +) + +(defgeneric geev! (a &optional vl vr) + (:documentation " + Syntax + ====== + (GEEV a [job]) + + Purpose: + ======== + Computes the eigenvalues and left/right eigenvectors of A. + + For an NxN matrix A, its eigenvalues are denoted by: + + lambda(i), j = 1 ,..., N + + The right eigenvectors of A are denoted by v(i) where: + + A * v(i) = lambda(i) * v(i) + + The left eigenvectors of A are denoted by u(i) where: + + H H + u(i) * A = lambda(i) * u(i) + + In matrix notation: + -1 + A = V E V + + and + -1 + H H + A = U E U + + where lambda(i) is the ith diagonal of the diagonal matrix E, + v(i) is the ith column of V and u(i) is the ith column of U. + + The computed eigenvectors are normalized to have Euclidean norm + equal to 1 and largest component real. + + Return Values: + ============== + + JOB Return Values + ------------------------------------------------------------------ + :NN (default) [1] (DIAG E) An Nx1 vector of eigenvalues + [2] INFO + + :VN or T [1] V + [2] E + [3] INFO + + :NV [1] E + [2] U + [3] INFO + + :VV [1] V + [2] E + [3] U + [3] INFO + + where INFO is T if successful, NIL otherwise. +")) + + diff --git a/src/lapack/geev.lisp b/src/lapack/geev.lisp index 935d4a0..531b004 100644 --- a/src/lapack/geev.lisp +++ b/src/lapack/geev.lisp @@ -94,51 +94,6 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package #:matlisp) -(deft/generic (t/lapack-geev-func #'subtypep) sym ()) - -(deft/method t/lapack-geev-func (sym real-tensor) () - 'dgeev) -;;Make API for real and complex versions similar. -(definline mzgeev (jobvl jobvr n a lda w rwork vl ldvl vr ldvr work lwork info) - (zgeev jobvl jobvr n a lda w vl ldvl vr ldvr work lwork rwork info)) -(deft/method t/lapack-geev-func (sym complex-tensor) () - 'mzgeev) -;; - -(deft/generic (t/geev-output-fix #'subtypep) sym (wr wi)) -(deft/method t/geev-output-fix (sym real-numeric-tensor) (wr wi) - (using-gensyms (decl (wr wi)) - (with-gensyms (ret) - `(let* (,@decl - (,ret (t/store-allocator ,sym (* 2 (length ,wr))))) - (declare (type ,(store-type sym) ,wr ,wi ,ret)) - (very-quickly - (loop :for i :from 0 :below (length ,wr) - :do (setf (aref ,ret (* 2 i)) (aref ,wr i) - (aref ,ret (1+ (* 2 i))) (aref ,wi i)))) - ,ret)))) - -(deft/method t/geev-output-fix (sym complex-numeric-tensor) (wr wi) - (using-gensyms (decl (wr)) - `(let (,@decl) - (declare (type ,(store-type sym) ,wr)) - ,wr))) - -(deft/generic (t/lapack-geev! #'subtypep) sym (A lda vl ldvl vr ldvr w st-w)) - -(deft/method t/lapack-potrf! (sym blas-numeric-tensor) (A lda uplo) - (using-gensyms (decl (A lda uplo)) - `(let* (,@decl) - (declare (type ,sym ,A) - (type index-type ,lda) - (type character ,uplo)) - (,(macroexpand-1 `(t/lapack-potrf-func ,sym)) - ,uplo - (nrows ,A) - (the ,(store-type sym) (store ,A)) ,lda - 0)))) - - (defgeneric geev (a &optional job) (:documentation " commit 69ca54a98c4e4a03e004268297644094b5541cae Author: Akshay Srinivasan <aks...@gm...> Date: Sat Aug 17 23:30:32 2013 -0700 Made changes to use (complex double-float) arrays in SBCL. diff --git a/src/base/einstein.lisp b/src/base/einstein.lisp index 64998a5..264aa92 100644 --- a/src/base/einstein.lisp +++ b/src/base/einstein.lisp @@ -121,7 +121,7 @@ (stp (when memp `(aref ,(car (getf plst :strides)) ,(position cidx (car ofst)))))) (get-incs (cdr idxs) (if memp (list `(the index-type (* ,(if tloop 1 stp) (aref ,(car (getf plst :dimensions)) ,(position cidx (car ofst)))))) nil) (if (or tloop (and (null acc) (not memp))) (cons nil decl) - (cons + (cons (if memp `(,dsym ,(if (null acc) stp `(the index-type (- ,stp ,@acc))) :type index-type) `(,dsym (the index-type (- ,@acc)) :type index-type)) diff --git a/src/base/tweakable.lisp b/src/base/tweakable.lisp index 6f8b0bb..86dca90 100644 --- a/src/base/tweakable.lisp +++ b/src/base/tweakable.lisp @@ -16,6 +16,8 @@ returns a 10x10 matrix with Column major order. ") +(defparameter *default-tensor-type* 'real-tensor) + (defparameter *check-after-initializing?* t " If t, then check for invalid values in the field of diff --git a/src/classes/numeric.lisp b/src/classes/numeric.lisp index 93893f5..6f3e87e 100644 --- a/src/classes/numeric.lisp +++ b/src/classes/numeric.lisp @@ -53,39 +53,42 @@ (deft/method t/l3-lb (sym complex-numeric-tensor) () '*complex-l3-fcall-lb*) -(deft/method t/store-element-type (sym complex-numeric-tensor) () - (let ((cplx-type (macroexpand-1 `(t/field-type ,sym)))) - (second cplx-type))) - -(deft/method t/compute-store-size (sym complex-numeric-tensor) (size) - `(* 2 ,size)) - -(deft/method t/store-ref (sym complex-numeric-tensor) (store idx) - (let ((store-s (gensym)) - (idx-s (gensym)) - (type (macroexpand-1 `(t/store-element-type ,sym)))) - `(let ((,store-s ,store) - (,idx-s ,idx)) - (declare (type (simple-array ,type) ,store-s)) - (complex (aref ,store-s (* 2 ,idx-s)) (aref ,store-s (1+ (* 2 ,idx-s))))))) - -(deft/method t/store-set (sym complex-numeric-tensor) (value store idx) - (let ((store-s (gensym)) - (idx-s (gensym)) - (value-s (gensym)) - (type (macroexpand-1 `(t/store-element-type ,sym))) - (ftype (macroexpand-1 `(t/field-type ,sym)))) - `(let ((,store-s ,store) - (,idx-s ,idx) - (,value-s ,value)) - (declare (type (simple-array ,type) ,store-s) - (type ,ftype ,value-s)) - (setf (aref ,store-s (* 2 ,idx-s)) (cl:realpart ,value-s) - (aref ,store-s (1+ (* 2 ,idx-s))) (cl:imagpart ,value-s)) - nil))) - -(defmethod store-size ((tensor complex-numeric-tensor)) - (floor (/ (length (store tensor)) 2))) +;;SBCL uses specialized arrays for floating complex arrays. +#-sbcl +(progn + (deft/method t/store-element-type (sym complex-numeric-tensor) () + (let ((cplx-type (macroexpand-1 `(t/field-type ,sym)))) + (second cplx-type))) + + (deft/method t/compute-store-size (sym complex-numeric-tensor) (size) + `(* 2 ,size)) + + (deft/method t/store-ref (sym complex-numeric-tensor) (store idx) + (let ((store-s (gensym)) + (idx-s (gensym)) + (type (macroexpand-1 `(t/store-element-type ,sym)))) + `(let ((,store-s ,store) + (,idx-s ,idx)) + (declare (type (simple-array ,type) ,store-s)) + (complex (aref ,store-s (* 2 ,idx-s)) (aref ,store-s (1+ (* 2 ,idx-s))))))) + + (deft/method t/store-set (sym complex-numeric-tensor) (value store idx) + (let ((store-s (gensym)) + (idx-s (gensym)) + (value-s (gensym)) + (type (macroexpand-1 `(t/store-element-type ,sym))) + (ftype (macroexpand-1 `(t/field-type ,sym)))) + `(let ((,store-s ,store) + (,idx-s ,idx) + (,value-s ,value)) + (declare (type (simple-array ,type) ,store-s) + (type ,ftype ,value-s)) + (setf (aref ,store-s (* 2 ,idx-s)) (cl:realpart ,value-s) + (aref ,store-s (1+ (* 2 ,idx-s))) (cl:imagpart ,value-s)) + nil))) + + (defmethod store-size ((tensor complex-numeric-tensor)) + (floor (/ (length (store tensor)) 2)))) (defmethod print-element ((tensor complex-numeric-tensor) element stream) @@ -105,4 +108,3 @@ (defleaf scomplex-tensor (complex-numeric-tensor) ()) (deft/method t/store-element-type (sym scomplex-tensor) () 'single-float)) - diff --git a/src/ffi/ffi-cffi.lisp b/src/ffi/ffi-cffi.lisp index 8ac6db3..5175304 100644 --- a/src/ffi/ffi-cffi.lisp +++ b/src/ffi/ffi-cffi.lisp @@ -146,6 +146,10 @@ (deftype matlisp-specialized-array () `(or (simple-array double-float (*)) (simple-array single-float (*)) + #+sbcl + (simple-array (complex double-float) (*)) + #+sbcl + (simple-array (complex single-float) (*)) ;; (simple-array (signed-byte 64) *) (simple-array (signed-byte 32) *) diff --git a/src/level-1/maker.lisp b/src/level-1/maker.lisp index cf41512..f101dba 100644 --- a/src/level-1/maker.lisp +++ b/src/level-1/maker.lisp @@ -22,7 +22,7 @@ (t/zeros ,dtype dims))) (zeros-generic dims dtype))) -(definline zeros (dims &optional (type 'real-tensor)) +(definline zeros (dims &optional (type *default-tensor-type*)) (let ((*check-after-initializing?* nil)) (let ((type (etypecase type (standard-class (class-name type)) (symbol type)))) (etypecase dims commit 6c6f96e88fab82f42a2cd563c53e90c48eb8da24 Author: Akshay Srinivasan <aks...@gm...> Date: Sat Aug 17 17:34:10 2013 -0700 Removed redundant files. diff --git a/src/classes/complex-tensor.lisp b/src/classes/complex-tensor.lisp deleted file mode 100644 index 272285a..0000000 --- a/src/classes/complex-tensor.lisp +++ /dev/null @@ -1,44 +0,0 @@ -(in-package #:matlisp) - -(defmacro-method field-type ((sym (eql 'complex-tensor))) - '(complex double-float)) - -(defmacro-method store-element-type ((sym (eql 'complex-tensor))) - 'double-float) - -(defmacro-method compute-store-size ((sym (eql 'complex-tensor)) size) - '(* 2 size)) - -(defmacro-method store-ref ((sym (eql 'complex-tensor)) store idx) - (let ((store-s (gensym)) - (idx-s (gensym)) - (type (macroexpand-1 `(store-element-type ,sym)))) - `(let ((,store-s ,store) - (,idx-s ,idx)) - (declare (type (simple-array ,type) ,store-s)) - (complex (aref ,store-s (* 2 ,idx-s... [truncated message content] |
From: Akshay S. <ak...@us...> - 2013-08-15 02:20:05
|
This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "matlisp". The branch, classy has been updated via 808353d428ddc07d365bf1de8abcc86f0179ee08 (commit) from f9bf6a61b1860942b520069596563b2db546f927 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 808353d428ddc07d365bf1de8abcc86f0179ee08 Author: Akshay Srinivasan <aks...@gm...> Date: Wed Aug 14 19:20:10 2013 -0700 Ported gemm. diff --git a/matlisp.asd b/matlisp.asd index 8450621..3f30b7d 100644 --- a/matlisp.asd +++ b/matlisp.asd @@ -153,7 +153,6 @@ :pathname "level-2" :depends-on ("matlisp-base" "matlisp-classes" "foreign-core" "matlisp-level-1") :components ((:file "gemv"))) - #+nil (:module "matlisp-level-3" :pathname "level-3" :depends-on ("matlisp-base" "matlisp-classes" "foreign-core" "matlisp-level-1" "matlisp-level-2") diff --git a/packages.lisp b/packages.lisp index 5c7413f..04096db 100644 --- a/packages.lisp +++ b/packages.lisp @@ -68,7 +68,7 @@ (defpackage "MATLISP-UTILITIES" (:use #:common-lisp #:matlisp-conditions) - (:export #:ensure-list #:id + (:export #:ensure-list #:id #:ieql #:vectorify #:copy-n #:ensure-args #:repsym #:findsym #:find-tag #:zip #:zip-eq #:zipsym @@ -92,7 +92,6 @@ #:inlining #:definline #:with-optimization #:quickly #:very-quickly #:slowly #:quickly-if)) - (defpackage "MATLISP-TEMPLATE" (:use #:common-lisp #:matlisp-utilities) (:export #:deft/generic #:deft/method #:remt/method)) diff --git a/src/base/blas-helpers.lisp b/src/base/blas-helpers.lisp index de623a8..dd3fdaa 100644 --- a/src/base/blas-helpers.lisp +++ b/src/base/blas-helpers.lisp @@ -24,12 +24,12 @@ (list csto-a? csto-b?))))) (definline fortran-nop (op) - (ecase op (#\t #\n) (#\n #\t))) + (ecase op (#\T #\N) (#\N #\T))) (defun split-job (job) (declare (type symbol job)) (let-typed ((name (symbol-name job) :type string)) - (loop :for x :across name :collect (char-downcase x)))) + (loop :for x :across name :collect (char-upcase x)))) (definline flip-major (job) (declare (type symbol job)) @@ -46,7 +46,7 @@ (cs (aref stds 1) :type index-type)) ;;Note that it is not required that (rs = nc * cs) or (cs = nr * rs) (cond - ((= cs 1) (values rs (fortran-nop op) :row-major)) + ((and (char/= op #\C) (= cs 1)) (values rs (fortran-nop op) :row-major)) ((= rs 1) (values cs op :col-major))))) ;;Stride makers. @@ -77,6 +77,29 @@ (defun make-stride (dims) (ecase *default-stride-ordering* (:row-major (make-stride-rmj dims)) (:col-major (make-stride-cmj dims)))) -(defun call-fortran? (x lb) +(defun call-fortran? ( x lb) (declare (type standard-tensor x)) (> (size x) lb)) + +(defmacro with-columnification ((type (&rest input) (&rest output)) &rest body) + (with-gensyms (cfunc) + (let ((input-syms (mapcar #'(lambda (x) + (assert (or (symbolp (second x)) (characterp (second x))) nil "Given a non-symbolic input.") + (gensym (symbol-name (car x)))) input)) + (output-syms (mapcar #'(lambda (mat) (gensym (symbol-name mat))) output))) + `(labels ((,cfunc (a &optional b) + (declare (type ,type a)) + (let ((ret (or b (let ((*default-stride-ordering* :col-major)) (t/zeros ,type (the index-store-vector (dimensions a))))))) + (declare (type ,type a ret)) + (t/copy! (,type ,type) a ret)))) + (let (,@(mapcar #'(lambda (x sym) (let ((mat (first x)) (job (second x))) + `(,sym (if (blas-matrix-compatiblep ,mat ,job) ,mat + (,cfunc ,mat))))) input input-syms) + ,@(mapcar #'(lambda (mat sym) `(,sym (if (eql (third (multiple-value-list (blas-matrix-compatiblep ,mat #\N))) :col-major) ,mat + (,cfunc ,mat)))) output output-syms)) + (declare (type ,type ,@(append input-syms output-syms))) + (symbol-macrolet (,@(mapcar #'(lambda (mat sym) `(,mat ,sym)) (append (mapcar #'car input) output) (append input-syms output-syms))) + ,@body) + ,@(mapcar #'(lambda (mat sym) `(unless (eql (third (multiple-value-list (blas-matrix-compatiblep ,mat #\N))) :col-major) + (,cfunc ,sym ,mat))) output output-syms) + nil))))) diff --git a/src/base/template.lisp b/src/base/template.lisp index f027c83..50a2d83 100644 --- a/src/base/template.lisp +++ b/src/base/template.lisp @@ -33,6 +33,7 @@ (declare (type ,ty ,@args)) (cl:/ ,@args)))) +;; (deft/generic (t/fc #'subtypep) ty (num)) (deft/method t/fc (ty number) (num) (with-gensyms (num-sym) @@ -51,7 +52,9 @@ `(defmethod fconj ((x ,clname)) (t/fc ,clname x))) (fc x)))) - +(defun field-realp (fil) + (eql (macroexpand-1 `(t/fc ,fil phi)) 'phi)) +;; (deft/generic (t/f= #'subtypep) ty (&rest nums)) (deft/method t/f= (ty number) (&rest nums) (let* ((decl (zipsym nums)) diff --git a/src/classes/numeric.lisp b/src/classes/numeric.lisp index 8605abb..93893f5 100644 --- a/src/classes/numeric.lisp +++ b/src/classes/numeric.lisp @@ -3,6 +3,12 @@ (defclass numeric-tensor (standard-tensor) ()) (deft/method t/field-type (sym numeric-tensor) () 'number) + +;; +(defleaf integer-tensor (numeric-tensor) ()) +(deft/method t/field-type (sym integer-tensor) () + 'integer) + ;; (defclass blas-numeric-tensor (numeric-tensor) ()) (deft/generic (t/l1-lb #'subtypep) sym ()) diff --git a/src/level-1/maker.lisp b/src/level-1/maker.lisp index 46a3f76..cf41512 100644 --- a/src/level-1/maker.lisp +++ b/src/level-1/maker.lisp @@ -4,7 +4,9 @@ (deft/method t/zeros (class standard-tensor) (dims &optional initial-element) (with-gensyms (astrs adims sizs) `(let* ((,adims (make-index-store ,dims))) + (declare (type index-store-vector ,adims)) (multiple-value-bind (,astrs ,sizs) (make-stride ,adims) + (declare (type index-store-vector ,astrs)) (make-instance ',class :dimensions ,adims :head 0 diff --git a/src/level-2/gemv.lisp b/src/level-2/gemv.lisp index 177d7c8..f793ccd 100644 --- a/src/level-2/gemv.lisp +++ b/src/level-2/gemv.lisp @@ -39,12 +39,14 @@ (type character ,transp)) (unless (t/f= ,(field-type sym) ,beta (t/fid* ,(field-type sym))) (t/scdi! ,sym ,beta ,y :scal? t :numx? t)) + ,@(when (field-realp (field-type sym)) + `((when (char= ,transp #\C) (setq ,transp #\T)))) ;;These loops are optimized for column major matrices - (ecase (char-upcase ,transp) + (ecase ,transp (#\N (einstein-sum ,sym (j i) (ref ,y i) (* ,alpha (ref ,A i j) (ref ,x j)) nil)) (#\T (einstein-sum ,sym (i j) (ref ,y i) (* ,alpha (ref ,A j i) (ref ,x j)) nil)) - (#\C (einstein-sum ,sym (j i) (ref ,y i) (* ,alpha (t/fc ,(field-type sym) (ref ,A i j)) (ref ,x j)) nil)) - (#\H (einstein-sum ,sym (i j) (ref ,y i) (* ,alpha (t/fc ,(field-type sym) (ref ,A j i)) (ref ,x j)) nil))) + ,@(unless (field-realp (field-type sym)) + `((#\C (einstein-sum ,sym (i j) (ref ,y i) (* ,alpha (t/fc ,(field-type sym) (ref ,A j i)) (ref ,x j)) nil))))) ,y))) ;;---------------------------------------------------------------;; @@ -72,48 +74,29 @@ JOB Operation --------------------------------------------------- :N (default) alpha * A * x + beta * y - :T alpha * transpose(A)* x + beta * y - :C alpha * conjugate(A) * x + beta * y - :H alpha * transpose o conjugate(A) + beta * y + :T alpha * A^T * x + beta * y + :C alpha * A^H * x + beta * y ") (:method :before (alpha (A standard-tensor) (x standard-tensor) beta (y standard-tensor) &optional (job :n)) - (assert (member job '(:n :t :c :h)) nil 'invalid-value - :given job :expected `(member job '(:n :t :c :h)) + (assert (member job '(:n :t :c)) nil 'invalid-value + :given job :expected `(member job '(:n :t :c)) :message "GEMV!: Given an unknown job.") (assert (not (eq x y)) nil 'invalid-arguments :message "GEMV!: x and y cannot be the same vector") (assert (and (tensor-vectorp x) (tensor-vectorp y) (tensor-matrixp A) (= (aref (the index-store-vector (dimensions x)) 0) - (aref (the index-store-vector (dimensions A)) (if (member job '(:t :h)) 0 1))) + (aref (the index-store-vector (dimensions A)) (if (member job '(:t :c)) 0 1))) (= (aref (the index-store-vector (dimensions y)) 0) - (aref (the index-store-vector (dimensions A)) (if (member job '(:t :h)) 1 0)))) + (aref (the index-store-vector (dimensions A)) (if (member job '(:t :c)) 1 0)))) nil 'tensor-dimension-mismatch))) -(defun ieql (&rest args) - (loop :for ele :in (cdr args) - :do (unless (eql (car args) ele) - (return nil)) - :finally (return t))) - -(defun >class (cls) - (let ((clist (reverse (sort cls #'coerceable?)))) - (loop :for ele :in (cdr clist) - :do (unless (coerceable? ele (car clist)) - (return nil)) - :finally (return (car clist))))) - -(defun tensor-coerce (ten cls &optional (duplicate? t)) - (let ((clname (if (typep cls 'standard-class) (class-name cls) cls))) - (if (and (not duplicate?) (typep ten clname)) ten - (copy! ten (zeros (dimensions ten) clname))))) - (defmethod gemv! (alpha (A standard-tensor) (x standard-tensor) beta (y standard-tensor) &optional (job :n)) (let ((clx (class-name (class-of x))) (cly (class-name (class-of y))) - (cla (class-name (class-of y)))) + (cla (class-name (class-of A)))) (assert (and (member cla *tensor-type-leaves*) (member clx *tensor-type-leaves*) (member cly *tensor-type-leaves*)) @@ -126,7 +109,7 @@ (beta (t/coerce ,(field-type clx) beta)) (cjob (aref (symbol-name job) 0))) (declare (type ,(field-type clx) alpha beta) - (type character trans-op)) + (type character cjob)) ,(recursive-append (when (subtypep clx 'blas-numeric-tensor) `(if (call-fortran? A (t/l2-lb ,cla)) @@ -144,7 +127,7 @@ y)) (gemv! alpha A x beta y job)) (t - (error "Don't know how to apply axpy! to classes ~a, ~a." clx cly))))) + (error "Don't know how to apply gemv! to classes ~a." (list cla clx cly)))))) ;;---------------------------------------------------------------;; (defgeneric gemv (alpha A x beta y &optional job) (:documentation @@ -167,9 +150,8 @@ JOB Operation --------------------------------------------------- :N (default) alpha * A * x + beta * y - :T alpha * A'* x + beta * y - :C alpha * conjugate(A) * x + beta * y - :H alpha * transpose o conjugate(A) + beta * y + :T alpha * A^T * x + beta * y + :C alpha * A^H * x + beta * y ")) (defmethod gemv (alpha (A standard-tensor) (x standard-tensor) diff --git a/src/level-3/gemm.lisp b/src/level-3/gemm.lisp index 776406f..7596787 100644 --- a/src/level-3/gemm.lisp +++ b/src/level-3/gemm.lisp @@ -14,7 +14,7 @@ `(let* (,@decl (,m (aref (the index-store-vector (dimensions ,C)) 0)) (,n (aref (the index-store-vector (dimensions ,C)) 1)) - (,k (aref (the index-store-vector (dimensions ,A)) (ecase (char-upcase ,transa) ((#\N #\C) 1) ((#\T #\H) 0))))) + (,k (aref (the index-store-vector (dimensions ,A)) (ecase (char-upcase ,transa) (#\N 1) ((#\T #\C) 0))))) (declare (type ,sym ,A ,B ,C) (type ,(field-type sym) ,alpha ,beta) (type index-type ,lda ,ldb ,ldc ,m ,n ,k) @@ -33,69 +33,45 @@ ;; (deft/generic (t/gemm! #'subtypep) sym (alpha A B beta C transa transb)) -;;Witness the power of macros, muggles! :) (deft/method t/gemm! (sym standard-tensor) (alpha A B beta C transa transb) - (using-gensyms (decl (alpha A x beta y transp)) + (using-gensyms (decl (alpha A B beta C transa transb)) `(let (,@decl) - (declare (type ,sym ,A ,x ,y) + (declare (type ,sym ,A ,B ,C) (type ,(field-type sym) ,alpha ,beta) - (type character ,transp)) + (type character ,transa ,transb)) (unless (t/f= ,(field-type sym) ,beta (t/fid* ,(field-type sym))) - (t/scdi! ,sym ,beta ,y :scal? t :numx? t)) + (t/scdi! ,sym ,beta ,C :scal? t :numx? t)) + ,@(when (field-realp (field-type sym)) + `((when (char= ,transa #\C) (setq ,transa #\T)) + (when (char= ,transb #\C) (setq ,transb #\T)))) ;;These loops are optimized for column major matrices - (ecase (char-upcase ,transp) - (#\N (einstein-sum ,sym (j i) (ref ,y i) (* ,alpha (ref ,A i j) (ref ,x j)) nil)) - (#\T (einstein-sum ,sym (i j) (ref ,y i) (* ,alpha (ref ,A j i) (ref ,x j)) nil)) - (#\C (einstein-sum ,sym (j i) (ref ,y i) (* ,alpha (t/fc ,(field-type sym) (ref ,A i j)) (ref ,x j)) nil)) - (#\H (einstein-sum ,sym (i j) (ref ,y i) (* ,alpha (t/fc ,(field-type sym) (ref ,A j i)) (ref ,x j)) nil))) - ,y))) - - -;;Real -(generate-typed-gemm! real-base-typed-gemm! - (real-tensor dgemm *real-l3-fcall-lb*)) - -(definline real-typed-gemm! (alpha A B beta C job) - (real-base-typed-gemm! alpha A B beta C - (apply #'combine-jobs - (mapcar #'(lambda (x) - (ecase x ((:n :t) x) (:h :t) (:c :n))) - (multiple-value-list (split-job job)))))) - -;;Complex -(generate-typed-gemm! complex-base-typed-gemm! - (complex-tensor zgemm *complex-l3-fcall-lb*)) - -(definline complex-typed-gemm! (alpha A B beta C job) - (declare (type complex-matrix A B C) - (type complex-type alpha beta) - (type symbol job)) - (multiple-value-bind (job-A job-B) (split-job job) - (if (and (member job-A '(:n :t)) - (member job-B '(:n :t))) - (complex-base-typed-gemm! alpha A B beta C job) - (let ((A (ecase job-A - ((:n :t) A) - ((:h :c) (let ((ret (complex-typed-copy! A (complex-typed-zeros (dimensions A))))) - (real-typed-num-scal! -1d0 (tensor-imagpart~ ret)) - ret)))) - (B (ecase job-B - ((:n :t) B) - ((:h :c) (let ((ret (complex-typed-copy! A (complex-typed-zeros (dimensions A))))) - (real-typed-num-scal! -1d0 (tensor-imagpart~ ret)) - ret)))) - (tjob (combine-jobs (ecase job-A ((:n :t) job-A) (:h :t) (:c :n)) - (ecase job-B ((:n :t) job-B) (:h :t) (:c :n))))) - (complex-base-typed-gemm! alpha A B - beta C tjob))))) - -;;Symbolic -#+maxima -(generate-typed-gemm! symbolic-base-typed-gemm! - (symbolic-tensor nil 0)) - + ,(labels ((transpose-ref (mat) + `(ref ,(cadr mat) ,@(reverse (cddr mat)))) + (conjugate-ref (mat) + `(t/fc ,(field-type sym) ,mat)) + (generate-mm-code (transa transb) + (destructuring-bind (A-ref B-ref) (mapcar #'(lambda (mat trans) (ecase trans + ((#\N #\T) mat) + ((#\C) (conjugate-ref mat)))) + (mapcar #'(lambda (mat trans) (ecase trans + ((#\N) mat) + ((#\T #\C) (transpose-ref mat)))) + (list `(ref ,A i k) `(ref ,B k j)) (list transa transb)) + (list transa transb)) + (let ((loopo (let ((ta (member transa '(#\T #\C))) + (tb (member transb '(#\T #\C)))) + (cond + ((and (not ta) (not tb)) `(j k i)) + ((and (not ta) tb) `(k j i)) + (t`(i j k)))))) + `(einstein-sum ,sym ,loopo (ref ,C i j) (* ,alpha ,A-ref ,B-ref) nil))))) + `(ecase ,transa + ,@(loop :for ta :across (if (field-realp (field-type sym)) "NT" "NTC") + :collect `(,ta (ecase ,transb + ,@(loop :for tb :across (if (field-realp (field-type sym)) "NT" "NTC") + :collect `(,tb ,(generate-mm-code ta tb)))))))) + ,C))) ;;---------------------------------------------------------------;; - (defgeneric gemm! (alpha A B beta C &optional job) (:documentation " @@ -118,20 +94,10 @@ JOB must be a keyword with two of these alphabets N Identity T Transpose - C Complex conjugate - H Hermitian transpose {conjugate transpose} - - so that (there are 4x4 operations in total). - - JOB Operation - --------------------------------------------------- - :NN (default) alpha * A * B + beta * C - :TN alpha * transpose(A) * B + beta * C - :NH alpha * A * transpose o conjugate(B) + beta * C - :HC alpha * transpose o conjugate(A) * conjugate(B) + beta * C + C Hermitian transpose {conjugate transpose} ") - (:method :before ((alpha number) (A standard-matrix) (B standard-matrix) - (beta number) (C standard-matrix) + (:method :before (alpha (A standard-tensor) (B standard-tensor) + beta (C standard-tensor) &optional (job :nn)) (let ((nr-a (nrows A)) (nc-a (ncols A)) @@ -140,64 +106,46 @@ (nr-c (nrows C)) (nc-c (ncols C))) (declare (type index-type nr-a nc-a nr-b nc-b nr-c nc-c)) - (let ((sjobs (multiple-value-list (split-job job)))) + (let ((sjobs (split-job job))) (assert (= (length sjobs) 2) nil 'invalid-arguments :message "Ill formed job") - (ecase (first sjobs) ((:n :c) t) ((:t :h) (rotatef nr-a nc-a))) - (ecase (second sjobs) ((:n :c) t) ((:t :h) (rotatef nr-b nc-b)))) + (ecase (first sjobs) (#\N t) ((#\T #\C) (rotatef nr-a nc-a))) + (ecase (second sjobs) ((#\N) t) ((#\T #\C) (rotatef nr-b nc-b)))) (assert (not (or (eq A C) (eq B C))) nil 'invalid-arguments :message "GEMM!: C = {A or B} is not allowed.") - (assert (and (= nr-c nr-a) + (assert (and (tensor-matrixp A) (tensor-matrixp B) (tensor-matrixp C) + (= nr-c nr-a) (= nc-a nr-b) (= nc-b nc-c)) nil 'tensor-dimension-mismatch)))) - -(defmethod gemm! ((alpha number) (a real-matrix) (b real-matrix) - (beta number) (c real-matrix) - &optional (job :nn)) - (real-typed-gemm! (coerce-real alpha) a b - (coerce-real beta) c job)) - -(defmethod gemm! ((alpha number) (a complex-matrix) (b complex-matrix) - (beta number) (c complex-matrix) - &optional (job :nn)) - (complex-typed-gemm! (coerce-complex alpha) a b - (coerce-complex beta) c job)) - -(defmethod gemm! ((alpha number) (a real-matrix) (b real-matrix) - (beta number) (c complex-matrix) - &optional (job :nn)) - (unless (= beta 1) - (scal! beta c)) - (unless (= alpha 0) - (if (complexp alpha) - (let ((A.x (make-real-tensor (nrows c) (ncols c))) - (vw.c (tensor-realpart~ c))) - (real-typed-gemm! (coerce-real 1) A B (coerce-real 0) A.x job) - ;;Re - (axpy! (realpart alpha) A.x vw.c) - ;;Im - (incf (head vw.c)) - (axpy! (imagpart alpha) A.x vw.c)) - (let ((vw.c (tensor-realpart~ c))) - (real-typed-gemm! (coerce-real alpha) A B - (coerce-real 1) vw.c job)))) - C) - -(defmethod gemm! ((alpha number) (a real-matrix) (b complex-matrix) - (beta number) (c complex-matrix) - &optional (job :nn)) - (let ((A.cplx (copy! A (make-complex-tensor (nrows a) (ncols a))))) - (complex-typed-gemm! (coerce-complex alpha) A.cplx B - (coerce-complex beta) C job)) - C) - -(defmethod gemm! ((alpha number) (a complex-matrix) (b real-matrix) - (beta number) (c complex-matrix) - &optional (job :nn)) - (let ((B.cplx (copy! B (make-complex-tensor (nrows B) (ncols B))))) - (complex-typed-gemm! (coerce-complex alpha) A B.cplx - (coerce-complex beta) C job)) - C) - + +(defmethod gemm! (alpha (A standard-tensor) (B standard-tensor) beta (C standard-tensor) &optional (job :nn)) + (let ((cla (class-name (class-of A))) + (clb (class-name (class-of B))) + (clc (class-name (class-of C)))) + (assert (and (member cla *tensor-type-leaves*) + (member clb *tensor-type-leaves*) + (member clc *tensor-type-leaves*)) + nil 'tensor-abstract-class :tensor-class (list cla clb clc)) + (cond + ((ieql cla clb clc) + (compile-and-eval + `(defmethod gemm! (alpha (A ,cla) (B ,clb) beta (C ,clc) &optional (job :nn)) + (let ((alpha (t/coerce ,(field-type cla) alpha)) + (beta (t/coerce ,(field-type cla) beta))) + (declare (type ,(field-type cla) alpha beta)) + (destructuring-bind (joba jobb) (split-job job) + (declare (type character joba jobb)) + ,(recursive-append + (when (subtypep clc 'blas-numeric-tensor) + `(if (call-fortran? C (t/l3-lb ,clc)) + (with-columnification (,cla ((a joba) (b jobb)) (c)) + (multiple-value-bind (lda opa) (blas-matrix-compatiblep a joba) + (multiple-value-bind (ldb opb) (blas-matrix-compatiblep b jobb) + (t/blas-gemm! ,cla alpha A lda B ldb beta C ldb opa opb)))))) + `(t/gemm! ,cla alpha A B beta C joba jobb)))) + C)) + (gemm! alpha A B beta C job)) + (t + (error "Don't know how to apply gemm! to classes ~a." (list cla clb clc)))))) ;;---------------------------------------------------------------;; (defgeneric gemm (alpha a b beta c &optional job) (:documentation @@ -221,46 +169,9 @@ JOB must be a keyword with two of these alphabets N Identity T Transpose - C Complex conjugate - H Hermitian transpose {conjugate transpose} - - so that (there are 4x4 operations in total). - - JOB Operation - --------------------------------------------------- - :NN (default) alpha * A * B + beta * C - :TN alpha * transpose(A) * B + beta * C - :NH alpha * A * transpose o conjugate(B) + beta * C - :HC alpha * transpose o conjugate(A) * conjugate(B) + beta * C + C Hermitian conjugate ")) -(defmethod gemm ((alpha number) (a standard-matrix) (b standard-matrix) - (beta number) (c complex-matrix) - &optional (job :nn)) - (let ((result (copy C))) - (gemm! alpha A B beta result job))) - -;; if all args are not real then at least one of them -;; is complex, so we need to call GEMM! with a complex C -(defmethod gemm ((alpha number) (a standard-matrix) (b standard-matrix) - (beta number) (c real-matrix) - &optional (job :nn)) - (let ((result (funcall (if (or (complexp alpha) (complexp beta) - (typep a 'complex-matrix) (typep b 'complex-matrix)) - #'complex-typed-zeros - #'real-typed-zeros) - (dimensions C)))) - (copy! C result) - (gemm! alpha A B beta result job))) - -(defmethod gemm ((alpha number) (a standard-matrix) (b standard-matrix) - (beta (eql nil)) (c (eql nil)) - &optional (job :nn)) - (multiple-value-bind (job-A job-B) (split-job job) - (let ((result (funcall (if (or (complexp alpha) (complexp beta) - (typep a 'complex-matrix) (typep b 'complex-matrix)) - #'complex-typed-zeros - #'real-typed-zeros) - (make-index-store (list (if (member job-A '(:n :c)) (nrows A) (ncols A)) - (if (member job-B '(:n :c)) (ncols B) (nrows B))))))) - (gemm! alpha A B 0 result job)))) +(defmethod gemm (alpha (A standard-tensor) (B standard-tensor) + beta (C standard-tensor) &optional (job :nn)) + (gemm! alpha A B beta (copy C) job)) diff --git a/src/utilities/functions.lisp b/src/utilities/functions.lisp index a224404..f790208 100644 --- a/src/utilities/functions.lisp +++ b/src/utilities/functions.lisp @@ -6,6 +6,12 @@ (declaim (inline id)) (defun id (x) x) +(defun ieql (&rest args) + (loop :for ele :in (cdr args) + :do (unless (eql (car args) ele) + (return nil)) + :finally (return t))) + (declaim (inline vectorify)) (defun vectorify (seq n &optional (element-type t)) (declare (type (or vector list) seq)) ----------------------------------------------------------------------- Summary of changes: matlisp.asd | 1 - packages.lisp | 3 +- src/base/blas-helpers.lisp | 31 +++++- src/base/template.lisp | 5 +- src/classes/numeric.lisp | 6 + src/level-1/maker.lisp | 2 + src/level-2/gemv.lisp | 50 +++------ src/level-3/gemm.lisp | 241 +++++++++++++----------------------------- src/utilities/functions.lisp | 6 + 9 files changed, 138 insertions(+), 207 deletions(-) hooks/post-receive -- matlisp |
From: Akshay S. <ak...@us...> - 2013-08-14 19:53:53
|
This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "matlisp". The branch, classy has been updated via f9bf6a61b1860942b520069596563b2db546f927 (commit) via be4148122456b5f7a6d4032fcba44e4652f4eb0b (commit) from 228188fe426f884dd6a1743578e879350b7050ec (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit f9bf6a61b1860942b520069596563b2db546f927 Author: Akshay Srinivasan <aks...@gm...> Date: Wed Aug 14 12:53:03 2013 -0700 Saving state. diff --git a/matlisp.asd b/matlisp.asd index 71aa515..8450621 100644 --- a/matlisp.asd +++ b/matlisp.asd @@ -147,11 +147,8 @@ :depends-on ("copy" "maker")) (:file "realimag" :depends-on ("copy")) - #+nil - ( (:file "trans" - :depends-on ("scal" "copy"))))) - #+nil + :depends-on ("scal" "copy")))) (:module "matlisp-level-2" :pathname "level-2" :depends-on ("matlisp-base" "matlisp-classes" "foreign-core" "matlisp-level-1") diff --git a/src/base/blas-helpers.lisp b/src/base/blas-helpers.lisp index 11ef0c0..de623a8 100644 --- a/src/base/blas-helpers.lisp +++ b/src/base/blas-helpers.lisp @@ -46,8 +46,8 @@ (cs (aref stds 1) :type index-type)) ;;Note that it is not required that (rs = nc * cs) or (cs = nr * rs) (cond - ((= cs 1) (values :row-major rs (fortran-nop op))) - ((= rs 1) (values :col-major cs op))))) + ((= cs 1) (values rs (fortran-nop op) :row-major)) + ((= rs 1) (values cs op :col-major))))) ;;Stride makers. (definline make-stride-rmj (dims) diff --git a/src/base/template.lisp b/src/base/template.lisp index bdf0d06..f027c83 100644 --- a/src/base/template.lisp +++ b/src/base/template.lisp @@ -145,8 +145,6 @@ :for eleb :in b :do (when (funcall func elea eleb) (return t)))) -) - ;;This one is hard to get one's brain around. (deft/generic (t/strict-coerce @@ -195,3 +193,5 @@ ;; (t/strict-coerce (fixnum real) x) -> (COERCE X 'REAL) ;; (t/strict-coerce (double-float t) x) -> X ;; (t/strict-coerce (fixnum (complex integer)) x) -> (COERCE X '(COMPLEX INTEGER)) + +) diff --git a/src/classes/numeric.lisp b/src/classes/numeric.lisp index aaeb41e..8605abb 100644 --- a/src/classes/numeric.lisp +++ b/src/classes/numeric.lisp @@ -99,3 +99,4 @@ (defleaf scomplex-tensor (complex-numeric-tensor) ()) (deft/method t/store-element-type (sym scomplex-tensor) () 'single-float)) + diff --git a/src/level-1/axpy.lisp b/src/level-1/axpy.lisp index 52aae00..d6dd42a 100644 --- a/src/level-1/axpy.lisp +++ b/src/level-1/axpy.lisp @@ -122,8 +122,6 @@ `(t/axpy! ,clx alpha x y)) y))) (axpy! alpha x y)) - ((coerceable? clx cly) - (axpy! alpha (coerce-tensor x cly) y)) (t (error "Don't know how to apply axpy! to classes ~a, ~a." clx cly))))) diff --git a/src/level-1/dot.lisp b/src/level-1/dot.lisp index 1866473..354c271 100644 --- a/src/level-1/dot.lisp +++ b/src/level-1/dot.lisp @@ -131,11 +131,5 @@ (t/dot ,clx x y t) (t/dot ,clx x y nil))))) (dot x y conjugate-p)) - ;;You pay the piper if you like mixing types. - ;;This is (or should be) a rare enough to not matter. - ((coerceable? clx cly) - (dot (coerce-tensor x cly) y conjugate-p)) - ((coerceable? cly clx) - (dot x (coerce-tensor y clx) conjugate-p)) (t (error "Don't know how to compute the dot product of ~a , ~a." clx cly))))) diff --git a/src/level-1/scal.lisp b/src/level-1/scal.lisp index 6a06b36..cedea4d 100644 --- a/src/level-1/scal.lisp +++ b/src/level-1/scal.lisp @@ -114,8 +114,6 @@ `(t/scdi! ,clx x y :scal? t :numx? nil)) y)) (scal! x y)) - ((coerceable? clx cly) - (scal! (coerce-tensor x cly) y)) (t (error "Don't know how to apply scal! to classes ~a, ~a." clx cly))))) @@ -170,8 +168,6 @@ `(t/scdi! ,clx x y :scal? nil :numx? nil)) y)) (div! x y)) - ((coerceable? clx cly) - (div! (coerce-tensor x cly) y)) (t (error "Don't know how to apply div! to classes ~a, ~a." clx cly))))) diff --git a/src/level-2/gemv.lisp b/src/level-2/gemv.lisp index 28a82d0..177d7c8 100644 --- a/src/level-2/gemv.lisp +++ b/src/level-2/gemv.lisp @@ -17,8 +17,6 @@ (declare (type ,sym ,A ,x ,y) (type ,(field-type sym) ,alpha ,beta) (type index-type ,st-x ,st-y ,lda ,m ,n)) - (when (cl:char= (char-upcase ,transp) #\T) - (rotatef ,m ,n)) (,(macroexpand-1 `(t/blas-gemv-func ,sym)) ,transp ,m ,n ,alpha @@ -27,7 +25,7 @@ ,beta (the ,(store-type sym) (store ,y)) ,st-y (the index-type (head ,A)) (the index-type (head ,x)) (the index-type (head ,y))) - y)))) + ,y)))) ;; (deft/generic (t/gemv! #'subtypep) sym (alpha A x beta y transp)) @@ -37,20 +35,19 @@ (using-gensyms (decl (alpha A x beta y transp)) `(let (,@decl) (declare (type ,sym ,A ,x ,y) - (type ,(field-type sym) ,alpha ,beta)) + (type ,(field-type sym) ,alpha ,beta) + (type character ,transp)) (unless (t/f= ,(field-type sym) ,beta (t/fid* ,(field-type sym))) (t/scdi! ,sym ,beta ,y :scal? t :numx? t)) ;;These loops are optimized for column major matrices - (if ,transp - (einstein-sum ,sym (i j) (ref ,y i) (* ,alpha (ref ,A j i) (ref ,x j)) nil) - (einstein-sum ,sym (j i) (ref ,y i) (* ,alpha (ref ,A i j) (ref ,x j)) nil)) + (ecase (char-upcase ,transp) + (#\N (einstein-sum ,sym (j i) (ref ,y i) (* ,alpha (ref ,A i j) (ref ,x j)) nil)) + (#\T (einstein-sum ,sym (i j) (ref ,y i) (* ,alpha (ref ,A j i) (ref ,x j)) nil)) + (#\C (einstein-sum ,sym (j i) (ref ,y i) (* ,alpha (t/fc ,(field-type sym) (ref ,A i j)) (ref ,x j)) nil)) + (#\H (einstein-sum ,sym (i j) (ref ,y i) (* ,alpha (t/fc ,(field-type sym) (ref ,A j i)) (ref ,x j)) nil))) ,y))) - -;;Symbolic -#+maxima -(generate-typed-gemv! symbolic-base-typed-gemv! - (symbolic-tensor nil 0)) ;;---------------------------------------------------------------;; + (defgeneric gemv! (alpha A x beta y &optional job) (:documentation " @@ -79,74 +76,75 @@ :C alpha * conjugate(A) * x + beta * y :H alpha * transpose o conjugate(A) + beta * y ") - (:method :before ((alpha number) (A standard-matrix) (x standard-vector) - (beta number) (y standard-vector) + (:method :before (alpha (A standard-tensor) (x standard-tensor) + beta (y standard-tensor) &optional (job :n)) (assert (member job '(:n :t :c :h)) nil 'invalid-value :given job :expected `(member job '(:n :t :c :h)) - :message "Inside gemv!") + :message "GEMV!: Given an unknown job.") (assert (not (eq x y)) nil 'invalid-arguments :message "GEMV!: x and y cannot be the same vector") (assert (and - (= (aref (dimensions x) 0) - (aref (dimensions A) (if (eq job :t) 0 1))) - (= (aref (dimensions y) 0) - (aref (dimensions A) (if (eq job :t) 1 0)))) + (tensor-vectorp x) (tensor-vectorp y) (tensor-matrixp A) + (= (aref (the index-store-vector (dimensions x)) 0) + (aref (the index-store-vector (dimensions A)) (if (member job '(:t :h)) 0 1))) + (= (aref (the index-store-vector (dimensions y)) 0) + (aref (the index-store-vector (dimensions A)) (if (member job '(:t :h)) 1 0)))) nil 'tensor-dimension-mismatch))) -(defmethod gemv! ((alpha number) (A real-matrix) (x real-vector) - (beta number) (y real-vector) &optional (job :n)) - (real-typed-gemv! (coerce-real alpha) A x - (coerce-real beta) y job)) - -(defmethod gemv! ((alpha number) (A complex-matrix) (x complex-vector) - (beta number) (y complex-vector) &optional (job :n)) - (complex-typed-gemv! (coerce-complex alpha) A x - (coerce-complex beta) y job)) - -(defmethod gemv! ((alpha number) (A real-matrix) (x real-vector) - (beta number) (y complex-vector) &optional (job :n)) - (unless (= beta 1) - (complex-typed-scal! (coerce-complex beta) y)) - (unless (= alpha 0) - (if (not (zerop (imagpart alpha))) - (let ((A.x (make-real-tensor (aref (dimensions y) 0))) - (vw-y (tensor-realpart~ y))) - (real-typed-gemv! (coerce-real 1) A x (coerce-real 0) A.x job) - ;; - (real-typed-axpy! (coerce-real (realpart alpha)) A.x vw-y) - ;;Move view to the imaginary part - (incf (head vw-y)) - (real-typed-axpy! (coerce-real (imagpart alpha)) A.x vw-y)) - (real-typed-gemv! (coerce-real alpha) A x - (coerce-real 1) (tensor-realpart~ y) job))) - y) - -(defmethod gemv! ((alpha number) (A real-matrix) (x complex-vector) - (beta number) (y complex-matrix) &optional (job :n)) - (unless (= beta 1) - (complex-typed-scal! (coerce-complex beta) y)) - (unless (= alpha 0) - (let ((A.x (make-complex-tensor (aref (dimensions y) 0)))) - (let ((vw-x (tensor-realpart~ x)) - (vw-A.x (tensor-realpart~ x))) - ;;Re - (real-typed-gemv! (coerce-real 1) A vw-x (coerce-real 0) vw-A.x job) - ;;Im - (incf (head vw-x)) - (incf (head vw-A.x)) - (real-typed-gemv! (coerce-real 1) A vw-x (coerce-real 0) vw-A.x job)) - (complex-typed-axpy! (coerce-complex alpha) A.x y))) - y) - -(defmethod gemv! ((alpha number) (A complex-matrix) (x real-vector) - (beta number) (y complex-vector) &optional (job :n)) - (let ((cplx-x (make-complex-tensor (aref (dimensions x) 0)))) - (real-typed-copy! x (tensor-realpart~ cplx-x)) - (complex-typed-gemv! (coerce-complex alpha) A cplx-x - (coerce-complex beta) y job)) - y) - +(defun ieql (&rest args) + (loop :for ele :in (cdr args) + :do (unless (eql (car args) ele) + (return nil)) + :finally (return t))) + +(defun >class (cls) + (let ((clist (reverse (sort cls #'coerceable?)))) + (loop :for ele :in (cdr clist) + :do (unless (coerceable? ele (car clist)) + (return nil)) + :finally (return (car clist))))) + +(defun tensor-coerce (ten cls &optional (duplicate? t)) + (let ((clname (if (typep cls 'standard-class) (class-name cls) cls))) + (if (and (not duplicate?) (typep ten clname)) ten + (copy! ten (zeros (dimensions ten) clname))))) + +(defmethod gemv! (alpha (A standard-tensor) (x standard-tensor) beta (y standard-tensor) &optional (job :n)) + (let ((clx (class-name (class-of x))) + (cly (class-name (class-of y))) + (cla (class-name (class-of y)))) + (assert (and (member cla *tensor-type-leaves*) + (member clx *tensor-type-leaves*) + (member cly *tensor-type-leaves*)) + nil 'tensor-abstract-class :tensor-class (list cla clx cly)) + (cond + ((ieql clx cly cla) + (compile-and-eval + `(defmethod gemv! (alpha (A ,cla) (x ,clx) beta (y ,cly) &optional (job :n)) + (let ((alpha (t/coerce ,(field-type clx) alpha)) + (beta (t/coerce ,(field-type clx) beta)) + (cjob (aref (symbol-name job) 0))) + (declare (type ,(field-type clx) alpha beta) + (type character trans-op)) + ,(recursive-append + (when (subtypep clx 'blas-numeric-tensor) + `(if (call-fortran? A (t/l2-lb ,cla)) + (let ((A-copy (if (blas-matrix-compatiblep A cjob) A + (let ((*default-stride-ordering* :col-major)) + (t/copy! (,cla ,cla) A (t/zeros ,clx (dimensions A))))))) + (multiple-value-bind (lda op maj) (blas-matrix-compatiblep A-copy cjob) + (declare (ignore maj)) + (t/blas-gemv! ,cla alpha A-copy lda + x (aref (the index-store-vector (strides x)) 0) + beta + y (aref (the index-store-vector (strides y)) 0) + op))))) + `(t/gemv! ,cla alpha A x beta y cjob))) + y)) + (gemv! alpha A x beta y job)) + (t + (error "Don't know how to apply axpy! to classes ~a, ~a." clx cly))))) ;;---------------------------------------------------------------;; (defgeneric gemv (alpha A x beta y &optional job) (:documentation @@ -174,26 +172,6 @@ :H alpha * transpose o conjugate(A) + beta * y ")) -(defmethod gemv ((alpha number) (A standard-matrix) (x standard-vector) - (beta number) (y complex-vector) &optional (job :n)) - (let ((result (copy y))) - (gemv! alpha A x 1d0 result job))) - -(defmethod gemv ((alpha number) (A standard-matrix) (x standard-vector) - (beta number) (y real-vector) &optional (job :n)) - (let ((result (if (or (complexp alpha) (complexp beta) - (typep A 'complex-matrix) (typep x 'complex-vector)) - (make-complex-tensor (aref (dimensions y) 0)) - (make-real-tensor (aref (dimensions y) 0))))) - (scal! y result) - (gemv! alpha A x beta result job))) - -(defmethod gemv ((alpha number) (A standard-matrix) (x standard-vector) - (beta (eql nil)) (y (eql nil)) &optional (job :n)) - (let ((result (apply - (if (or (complexp alpha) (complexp beta) - (typep A 'complex-matrix) (typep x 'complex-vector)) - #'make-complex-tensor - #'make-real-tensor) - (list (ecase job ((:n :c) (nrows A)) ((:t :h) (ncols A))))))) - (gemv! alpha A x 0 result job))) +(defmethod gemv (alpha (A standard-tensor) (x standard-tensor) + beta (y standard-tensor) &optional (job :n)) + (gemv! alpha A x beta (copy y) job)) diff --git a/src/level-3/gemm.lisp b/src/level-3/gemm.lisp index b24fc76..776406f 100644 --- a/src/level-3/gemm.lisp +++ b/src/level-3/gemm.lisp @@ -1,260 +1,56 @@ -;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Package: :matlisp; Base: 10 -*- -;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Copyright (c) 2000 The Regents of the University of California. -;;; All rights reserved. -;;; -;;; Permission is hereby granted, without written agreement and without -;;; license or royalty fees, to use, copy, modify, and distribute this -;;; software and its documentation for any purpose, provided that the -;;; above copyright notice and the following two paragraphs appear in all -;;; copies of this software. -;;; -;;; IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY -;;; FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES -;;; ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF -;;; THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF -;;; SUCH DAMAGE. -;;; -;;; THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, -;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF -;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE -;;; PROVIDED HEREUNDER IS ON AN "AS IS" BASIS, AND THE UNIVERSITY OF -;;; CALIFORNIA HAS NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, -;;; ENHANCEMENTS, OR MODIFICATIONS. -;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (in-package #:matlisp) -(defmacro generate-typed-gemm! (func (tensor-class blas-gemm-func fortran-lb-parameter)) - (let* ((opt (if-ret (get-tensor-class-optimization-hashtable tensor-class) - (error 'tensor-cannot-find-optimization :tensor-class tensor-class))) - (matrix-class (getf opt :matrix)) - (blas? blas-gemm-func)) - `(progn - (eval-when (:compile-toplevel :load-toplevel :execute) - (let ((opt (get-tensor-class-optimization-hashtable ',tensor-class))) - (assert opt nil 'tensor-cannot-find-optimization :tensor-class ',tensor-class) - (setf (getf opt :gemm) ',func - (get-tensor-class-optimization ',tensor-class) opt))) - (defun ,func (alpha A B beta C job) - (declare (type ,(getf opt :element-type) alpha beta) - (type ,matrix-class A B C) - (type symbol job)) - ,(let - ((lisp-routine - `(let-typed ((nr-C (nrows C) :type index-type) - (nc-C (ncols C) :type index-type) - (dotl (ecase job-A (:n (ncols A)) (:t (nrows A))) :type index-type) - ; - (rstp-A (row-stride A) :type index-type) - (cstp-A (col-stride A) :type index-type) - (hd-A (head A) :type index-type) - ; - (rstp-B (row-stride B) :type index-type) - (cstp-B (col-stride B) :type index-type) - (hd-B (head B) :type index-type) - ; - (rstp-C (row-stride C) :type index-type) - (cstp-C (col-stride C) :type index-type) - (hd-C (head C) :type index-type)) - ;; - (when (eq job-A :t) - (rotatef rstp-A cstp-A)) - (when (eq job-B :t) - (rotatef rstp-B cstp-B)) - ;; - (unless (,(getf opt :f=) beta (,(getf opt :fid*))) - (,(getf opt :num-scal) beta C)) - ;;Most of these loop orderings are borrowed from the Fortran reference - ;;implementation of BLAS. - (cond - ((and (= cstp-C 1) (= cstp-B 1)) - (let-typed ((of-A hd-A :type index-type) - (of-B hd-B :type index-type) - (of-C hd-C :type index-type) - (d.rstp-B (- rstp-B nc-C) :type index-type) - (d.rstp-A (- rstp-A (* cstp-A dotl)) :type index-type) - (sto-A (store A) :type ,(linear-array-type (getf opt :store-type))) - (sto-B (store B) :type ,(linear-array-type (getf opt :store-type))) - (sto-C (store C) :type ,(linear-array-type (getf opt :store-type)))) - (very-quickly - (loop :repeat nr-C - :do (progn - (loop :repeat dotl - :do (let-typed - ((ele-A (,(getf opt :f*) alpha (,(getf opt :reader) sto-A of-A)) :type ,(getf opt :element-type))) - (loop :repeat nc-C - :do (progn - (,(getf opt :value-incfer) (,(getf opt :f*) ele-A (,(getf opt :reader) sto-B of-B)) - sto-C of-C) - (incf of-C) - (incf of-B))) - (decf of-C nc-C) - (incf of-A cstp-A) - (incf of-B d.rstp-B))) - (incf of-C rstp-C) - (incf of-A d.rstp-A) - (setf of-B hd-B)))))) - ((and (= cstp-A 1) (= rstp-B 1)) - (let-typed ((of-A hd-A :type index-type) - (of-B hd-B :type index-type) - (of-C hd-C :type index-type) - (d.cstp-B (- cstp-B dotl) :type index-type) - (d.rstp-C (- rstp-C (* nc-C cstp-C)) :type index-type) - (sto-A (store A) :type ,(linear-array-type (getf opt :store-type))) - (sto-B (store B) :type ,(linear-array-type (getf opt :store-type))) - (sto-C (store C) :type ,(linear-array-type (getf opt :store-type))) - (dot (,(getf opt :fid+)) :type ,(getf opt :element-type))) - (very-quickly - (loop :repeat nr-C - :do (progn - (loop :repeat nc-C - :do (progn - (setf dot (,(getf opt :fid+))) - (loop :repeat dotl - :do (progn - (setf dot (,(getf opt :f+) dot (,(getf opt :f*) (,(getf opt :reader) sto-A of-A) (,(getf opt :reader) sto-B of-B)))) - (incf of-A) - (incf of-B))) - (,(getf opt :value-incfer) dot sto-C of-C) - (incf of-C cstp-C) - (decf of-A dotl) - (incf of-B d.cstp-B))) - (incf of-C d.rstp-C) - (incf of-A rstp-A) - (setf of-B hd-B)))))) - ((and (= cstp-A 1) (= rstp-B 1)) - (let-typed ((of-A hd-A :type index-type) - (of-B hd-B :type index-type) - (of-C hd-C :type index-type) - (d.cstp-B (- cstp-B dotl) :type index-type) - (d.rstp-C (- rstp-C (* nc-C cstp-C)) :type index-type) - (sto-A (store A) :type ,(linear-array-type (getf opt :store-type))) - (sto-B (store B) :type ,(linear-array-type (getf opt :store-type))) - (sto-C (store C) :type ,(linear-array-type (getf opt :store-type))) - (dot (,(getf opt :fid+)) :type ,(getf opt :element-type))) - (very-quickly - (loop :repeat nr-C - :do (progn - (loop :repeat nc-C - :do (progn - (setf dot (,(getf opt :fid+))) - (loop :repeat dotl - :do (progn - (setf dot (,(getf opt :f+) dot (,(getf opt :f*) (,(getf opt :reader) sto-A of-A) (,(getf opt :reader) sto-B of-B)))) - (incf of-A) - (incf of-B))) - (,(getf opt :value-incfer) dot sto-C of-C) - (incf of-C cstp-C) - (decf of-A dotl) - (incf of-B d.cstp-B))) - (incf of-C d.rstp-C) - (incf of-A rstp-A) - (setf of-B hd-B)))))) - ((and (= rstp-A 1) (= rstp-C 1)) - (let-typed ((of-A hd-A :type index-type) - (of-B hd-B :type index-type) - (of-C hd-C :type index-type) - (d.cstp-B (- cstp-B (* rstp-B dotl)) :type index-type) - (d.cstp-A (- cstp-A nr-C) :type index-type) - (sto-A (store A) :type ,(linear-array-type (getf opt :store-type))) - (sto-B (store B) :type ,(linear-array-type (getf opt :store-type))) - (sto-C (store C) :type ,(linear-array-type (getf opt :store-type)))) - (very-quickly - (loop :repeat nc-C - :do (progn - (loop :repeat dotl - :do (let-typed - ((ele-B (,(getf opt :f*) alpha (,(getf opt :reader) sto-B of-B)) :type ,(getf opt :element-type))) - (loop :repeat nr-C - :do (progn - (,(getf opt :value-incfer) (,(getf opt :f*) ele-B (,(getf opt :reader) sto-A of-A)) - sto-C of-C) - (incf of-C) - (incf of-A))) - (decf of-C nr-C) - (incf of-A d.cstp-A) - (incf of-B rstp-B))) - (incf of-C cstp-C) - (setf of-A hd-A) - (incf of-B d.cstp-B)))))) - (t - (let-typed ((of-A hd-A :type index-type) - (of-B hd-B :type index-type) - (of-C hd-C :type index-type) - (r.cstp-C (* cstp-C nc-C) :type index-type) - (d.rstp-B (- rstp-B (* cstp-B nc-C)) :type index-type) - (d.rstp-A (- rstp-A (* cstp-A dotl)) :type index-type) - (sto-A (store A) :type ,(linear-array-type (getf opt :store-type))) - (sto-B (store B) :type ,(linear-array-type (getf opt :store-type))) - (sto-C (store C) :type ,(linear-array-type (getf opt :store-type)))) - (very-quickly - (loop :repeat nr-C - :do (progn - (loop :repeat dotl - :do (let-typed - ((ele-A (,(getf opt :f*) alpha (,(getf opt :reader) sto-A of-A)) :type ,(getf opt :element-type))) - (loop :repeat nc-C - :do (progn - (,(getf opt :value-writer) - (,(getf opt :f+) - (,(getf opt :reader) sto-C of-C) - (,(getf opt :f*) ele-A (,(getf opt :reader) sto-B of-B))) - sto-C of-C) - (incf of-C cstp-C) - (incf of-B cstp-B))) - (decf of-C r.cstp-C) - (incf of-A cstp-A) - (incf of-B d.rstp-B))) - (incf of-C rstp-C) - (incf of-A d.rstp-A) - (setf of-B hd-B)))))))))) - ;;Tie together Fortran and lisp-routines. - `(mlet* (((job-A job-B) (ecase job - (:nn (values :n :n)) - (:nt (values :n :t)) - (:tn (values :t :n)) - (:tt (values :t :t))) - :type (symbol symbol)) - ,@(when blas? - `((call-fortran? (> (max (nrows C) (ncols C) (if (eq job-A :n) (ncols A) (nrows A))) - ,fortran-lb-parameter)) - ((maj-A ld-A fop-A) (blas-matrix-compatible-p A job-A) :type (symbol index-type (string 1))) - ((maj-B ld-B fop-B) (blas-matrix-compatible-p B job-B) :type (symbol index-type (string 1))) - ((maj-C ld-C fop-C) (blas-matrix-compatible-p C :n) :type (symbol index-type nil))))) - ,(if blas? - `(cond - (call-fortran? - (if (and maj-A maj-B maj-C) - (let-typed ((nr-C (nrows C) :type index-type) - (nc-C (ncols C) :type index-type) - (dotl (ecase job-A (:n (ncols A)) (:t (nrows A))) :type index-type)) - (when (eq maj-C :row-major) - (rotatef A B) - (rotatef ld-A ld-B) - (rotatef maj-A maj-B) - (rotatef nr-C nc-C) - (setf (values fop-A fop-B) - (values (fortran-snop fop-B) (fortran-snop fop-A)))) - (,blas-gemm-func fop-A fop-B nr-C nc-C dotl - alpha (store A) ld-A (store B) ld-B - beta (store C) ld-C - (head A) (head B) (head C))) - (let ((ret (,func alpha - (if maj-A A (,(getf opt :copy) A (,(getf opt :zero-maker) (dimensions A)))) - (if maj-B B (,(getf opt :copy) B (,(getf opt :zero-maker) (dimensions B)))) - beta - (if maj-C C (,(getf opt :copy) C (,(getf opt :zero-maker) (dimensions C)))) - job))) - (unless maj-C - (,(getf opt :copy) ret C))))) - (t - ,lisp-routine)) - lisp-routine))) - C)))) +(deft/generic (t/blas-gemm-func #'subtypep) sym ()) +(deft/method t/blas-gemm-func (sym real-tensor) () + 'dgemm) +(deft/method t/blas-gemm-func (sym complex-tensor) () + 'zgemm) +;; +(deft/generic (t/blas-gemm! #'subtypep) sym (alpha A lda B ldb beta C ldc transa transb)) + +(deft/method t/blas-gemm! (sym blas-numeric-tensor) (alpha A lda B ldb beta C ldc transa transb) + (using-gensyms (decl (alpha A lda B ldb beta C ldc transa transb)) + (with-gensyms (m n k) + `(let* (,@decl + (,m (aref (the index-store-vector (dimensions ,C)) 0)) + (,n (aref (the index-store-vector (dimensions ,C)) 1)) + (,k (aref (the index-store-vector (dimensions ,A)) (ecase (char-upcase ,transa) ((#\N #\C) 1) ((#\T #\H) 0))))) + (declare (type ,sym ,A ,B ,C) + (type ,(field-type sym) ,alpha ,beta) + (type index-type ,lda ,ldb ,ldc ,m ,n ,k) + (type character ,transa ,transb)) + (,(macroexpand-1 `(t/blas-gemm-func ,sym)) + ,transa ,transb + ,m ,n ,k + ,alpha + (the ,(store-type sym) (store ,A)) ,lda + (the ,(store-type sym) (store ,B)) ,ldb + ,beta + (the ,(store-type sym) (store ,C)) ,ldc + (the index-type (head ,A)) (the index-type (head ,B)) (the index-type (head ,C))) + ,C)))) + +;; +(deft/generic (t/gemm! #'subtypep) sym (alpha A B beta C transa transb)) + +;;Witness the power of macros, muggles! :) +(deft/method t/gemm! (sym standard-tensor) (alpha A B beta C transa transb) + (using-gensyms (decl (alpha A x beta y transp)) + `(let (,@decl) + (declare (type ,sym ,A ,x ,y) + (type ,(field-type sym) ,alpha ,beta) + (type character ,transp)) + (unless (t/f= ,(field-type sym) ,beta (t/fid* ,(field-type sym))) + (t/scdi! ,sym ,beta ,y :scal? t :numx? t)) + ;;These loops are optimized for column major matrices + (ecase (char-upcase ,transp) + (#\N (einstein-sum ,sym (j i) (ref ,y i) (* ,alpha (ref ,A i j) (ref ,x j)) nil)) + (#\T (einstein-sum ,sym (i j) (ref ,y i) (* ,alpha (ref ,A j i) (ref ,x j)) nil)) + (#\C (einstein-sum ,sym (j i) (ref ,y i) (* ,alpha (t/fc ,(field-type sym) (ref ,A i j)) (ref ,x j)) nil)) + (#\H (einstein-sum ,sym (i j) (ref ,y i) (* ,alpha (t/fc ,(field-type sym) (ref ,A j i)) (ref ,x j)) nil))) + ,y))) + + ;;Real (generate-typed-gemm! real-base-typed-gemm! (real-tensor dgemm *real-l3-fcall-lb*)) diff --git a/tests/tcomp.lisp b/tests/tcomp.lisp index 8f7e990..d7bd73d 100644 --- a/tests/tcomp.lisp +++ b/tests/tcomp.lisp @@ -47,9 +47,28 @@ t) (defun mv-test (A b c) - (t/gemv! real-tensor 1d0 A b 0d0 c nil)) - + (t/gemv! real-tensor 1d0 A b 2d0 c #\t)) + +(let ((A (zeros '(1000 1000))) + (x (zeros 1000)) + (y (zeros 1000))) + (let-typed ((sto-x (store x) :type (simple-array double-float)) + (sto-y (store y) :type (simple-array double-float)) + (sto-a (store A) :type (simple-array double-float))) + (loop :for i :from 0 :below (array-dimension sto-x 0) + :do (setf (aref sto-x i) (random 1d0) + (aref sto-y i) (random 1d0))) + (loop :for i :from 0 :below (array-dimension sto-a 0) + :do (setf (aref sto-a i) (random 1d0)))) + (time (let ((*real-l2-fcall-lb* (* 1000 2000))) (gemv! 1 A x 1 y))) + t) + (let ((A (copy! #2a((1 2) (3 4)) (zeros '(2 2)))) (b (copy! 1 (zeros 2))) (c (copy! #(1 2) (zeros 2)))) (time (dotimes (i 1000) (mv-test A b c)))) + +(let ((A (copy! #2a((1 2) (3 4)) (zeros '(2 2)))) + (b (copy! 1 (zeros 2))) + (c (copy! #(1 2) (zeros 2)))) + (time (dotimes (i 1000) (gemv! 1 A b 0 c :n)))) commit be4148122456b5f7a6d4032fcba44e4652f4eb0b Author: Akshay Srinivasan <aks...@gm...> Date: Sat Aug 10 09:51:28 2013 -0700 Added gemv template using einstein. diff --git a/src/base/einstein.lisp b/src/base/einstein.lisp index ac0ada7..64998a5 100644 --- a/src/base/einstein.lisp +++ b/src/base/einstein.lisp @@ -69,6 +69,7 @@ tmp))) (values refs tlist indices))) +;;Add options (allow function to compile the clause ?) for more compiler options. (defun loop-generator-base (type index-order place clause &key (testp t) (tight-iloop nil)) (multiple-value-bind (refs tlist indices) (parse-loopx type place clause) (let* ((tens (mapcar #'(lambda (x) (second (getf x :tensor))) tlist)) @@ -219,8 +220,8 @@ (defmacro einstein-sum (type idx-order place clause &optional (testp t)) (loop-generator type idx-order place clause :testp testp)) -;;Yes this is slow, but if you're *really* worried about computation then roll your custom loops -;;with einstein-sum-base. This is a super-adaptive on-the-fly loop generation function generation +;;Yes this has an overhead, but if you're *really* worried about efficiency then roll your custom loops +;;with einstein-sum-base. This is a super-adaptive on-the-fly-loop-generating-function generating ;;macro. You have the power now, without any of the tedium :) (defmacro define-einstein-sum (name args (type place clause &optional (testp t))) (multiple-value-bind (refs tlist indices) (parse-loopx type place clause) @@ -236,7 +237,7 @@ (let* ((code (loop-generator ',type idx-ord ',place ',clause :testp ,testp)) (funcnew (compile-and-eval (list 'lambda '(,@args) code)))) - (format t "Compiling code for index-order : ~a~%" idx-ord) + (format t "~a: Compiling code for index-order : ~a~%" ,(symbol-name name) idx-ord) (setf (gethash idx-ord ,functable) funcnew) funcnew)))) (apply func (list ,@args)))))))) diff --git a/src/level-2/gemv.lisp b/src/level-2/gemv.lisp index 29c6cbb..28a82d0 100644 --- a/src/level-2/gemv.lisp +++ b/src/level-2/gemv.lisp @@ -9,194 +9,48 @@ (deft/generic (t/blas-gemv! #'subtypep) sym (alpha A lda x st-x beta y st-y transp)) (deft/method t/blas-gemv! (sym blas-numeric-tensor) (alpha A lda x st-x beta y st-y transp) - (using-gensyms (decl (alpha A lda x st-x beta y st-y transp)) - (with-gensyms (m n) - `(let* (,@decl - (,m (aref (the index-store-vector (dimensions ,A)) 0)) - (,n (aref (the index-store-vector (dimensions ,A)) 1))) - (declare (type ,sym ,A ,x ,y) - (type ,(field-type sym) ,alpha ,beta) - (type index-type ,st-x ,st-y ,lda ,m ,n)) - (when (cl:char= (char-upcase ,transp) #\T) - (rotatef ,m ,n)) - (,(macroexpand-1 `(t/blas-gemv-func ,sym)) - ,transp ,m ,n - ,alpha - (the ,(store-type sym) (store ,A)) ,lda - (the ,(store-type sym) (store ,x)) ,st-x - ,beta - (the ,(store-type sym) (store ,y)) ,st-y - (the index-type (head ,A)) (the index-type (head ,x)) (the index-type (head ,y))) - y)))) + (using-gensyms (decl (alpha A lda x st-x beta y st-y transp)) + (with-gensyms (m n) + `(let* (,@decl + (,m (aref (the index-store-vector (dimensions ,A)) 0)) + (,n (aref (the index-store-vector (dimensions ,A)) 1))) + (declare (type ,sym ,A ,x ,y) + (type ,(field-type sym) ,alpha ,beta) + (type index-type ,st-x ,st-y ,lda ,m ,n)) + (when (cl:char= (char-upcase ,transp) #\T) + (rotatef ,m ,n)) + (,(macroexpand-1 `(t/blas-gemv-func ,sym)) + ,transp ,m ,n + ,alpha + (the ,(store-type sym) (store ,A)) ,lda + (the ,(store-type sym) (store ,x)) ,st-x + ,beta + (the ,(store-type sym) (store ,y)) ,st-y + (the index-type (head ,A)) (the index-type (head ,x)) (the index-type (head ,y))) + y)))) ;; (deft/generic (t/gemv! #'subtypep) sym (alpha A x beta y transp)) -(deft/method t/gemv! (sym standard-tensor) (alpha A x beta y transp)) - -(let ((A (copy! #2a((2 1) (3 4)) (zeros '(2 2 )))) - (x (copy! #(1 2) (zeros 2))) - (y (copy! #(0 1) (zeros 2)))) - (t/blas-gemv! real-tensor 1d0 A 2 x 1 0d0 y 1 t)) - - -(deft/method t/blas-axpy! (sym blas-numeric-tensor) (a x st-x y st-y) - (let ((apy? (null x))) - (using-gensyms (decl (a x y)) - (with-gensyms (sto-x stp-x) - `(let (,@decl) - (declare (type ,sym ,@(unless apy? `(,x)) ,y) - ,@(when apy? `((ignore ,x)))) - (let ((,sto-x ,(if apy? `(t/store-allocator ,sym 1) `(store ,x))) - (,stp-x ,(if apy? 0 st-x))) - (declare (type ,(store-type sym) ,sto-x) - (type index-type ,stp-x)) - ,@(when apy? - `((t/store-set ,sym (t/fid* ,(field-type sym)) ,sto-x 0))) - (,(macroexpand-1 `(t/blas-axpy-func ,sym)) - (the index-type (size ,y)) - (the ,(field-type sym) ,a) - ,sto-x ,stp-x - (the ,(store-type sym) (store ,y)) (the index-type ,st-y) - ,(if apy? 0 `(head ,x)) (head ,y)) - ,y)))))) - -(deft/generic (t/axpy! #'subtypep) sym (a x y)) -(deft/method t/axpy! (sym standard-tensor) (a x y) - (let ((apy? (null x))) - (using-gensyms (decl (a x y)) - (with-gensyms (idx sto-x sto-y of-x of-y) - `(let (,@decl) - (declare (type ,sym ,@(unless apy? `(,x)) ,y) - (type ,(field-type sym) ,a) - ,@(when apy? `((ignore ,x)))) - (let (,@(unless apy? `((,sto-x (store ,x)))) - (,sto-y (store ,y))) - (declare (type ,(store-type sym) ,@(unless apy? `(,sto-x)) ,sto-y)) - (very-quickly - (mod-dotimes (,idx (dimensions ,y)) - :with (linear-sums - ,@(unless apy? `((,of-x (strides ,x) (head ,x)))) - (,of-y (strides ,y) (head ,y))) - :do (t/store-set ,sym (t/f+ ,(field-type sym) - ,@(if apy? - `(,a) - `((t/f* ,(field-type sym) - ,a (t/store-ref ,sym ,sto-x ,of-x)))) - (t/store-ref ,sym ,sto-y ,of-y)) - ,sto-y ,of-y))) - ,y)))))) - - -(defmacro generate-typed-gemv! (func - (tensor-class blas-gemv-func - fortran-call-lb)) - (let* ((opt (if-ret (get-tensor-class-optimization-hashtable tensor-class) - (error 'tensor-cannot-find-optimization :tensor-class tensor-class))) - (matrix-class (getf opt :matrix)) - (vector-class (getf opt :vector))) - `(progn - (eval-when (:compile-toplevel :load-toplevel :execute) - (let ((opt (get-tensor-class-optimization-hashtable ',tensor-class))) - (assert opt nil 'tensor-cannot-find-optimization :tensor-class ',tensor-class) - (setf (getf opt :gemv) ',func - (get-tensor-class-optimization ',tensor-class) opt))) - (defun ,func (alpha A x beta y job) - (declare (type ,(getf opt :element-type) alpha beta) - (type ,matrix-class A) - (type ,vector-class x y) - (type list job)) - ,(let - ((lisp-routine - `(let-typed ((nr-A (nrows A) :type index-type) - (nc-A (ncols A) :type index-type) - (rs-A (row-stride A) :type index-type) - (cs-A (col-stride A) :type index-type) - (sto-A (store A) :type ,(linear-array-type (getf opt :store-type))) - ; - (stp-x (aref (strides x) 0) :type index-type) - (sto-x (store x) :type ,(linear-array-type (getf opt :store-type))) - (hd-x (head x) :type index-type) - ; - (stp-y (aref (strides y) 0) :type index-type) - (sto-y (store y) :type ,(linear-array-type (getf opt :store-type))) - ; - (job (car job) :type character)) - (when (char= job #\T) - (rotatef nr-A nc-A) - (rotatef rs-A cs-A)) - (very-quickly - (loop :repeat nr-A - :for of-y :of-type index-type := (head y) :then (+ of-y stp-y) - :for rof-A :of-type index-type := (head A) :then (+ rof-A rs-A) - :do (let-typed ((val (,(getf opt :f*) beta (,(getf opt :reader) sto-y of-y)) :type ,(getf opt :element-type))) - (loop :repeat nc-A - :for of-x :of-type index-type := hd-x :then (+ of-x stp-x) - :for of-A :of-type index-type := rof-A :then (+ of-A cs-A) - :with dot :of-type ,(getf opt :element-type) = (,(getf opt :fid+)) - :do (let-typed ((xval (,(getf opt :reader) sto-x of-x) :type ,(getf opt :element-type)) - (Aval (,(getf opt :reader) sto-A of-A) :type ,(getf opt :element-type))) - (setf dot (,(getf opt :f+) dot (,(getf opt :f*) xval Aval)))) - :finally (,(getf opt :value-writer) (,(getf opt :f+) (,(getf opt :f*) alpha dot) val) sto-y of-y)))))))) - (if blas-gemv-func - `(mlet* - ((call-fortran? (> (max (nrows A) (ncols A)) ,fortran-call-lb)) - ((maj-A ld-A fop-A) (blas-matrix-compatible-p A job) :type (symbol index-type character))) - (cond - (call-fortran? - (if maj-A - (let-typed ((nr-A (nrows A) :type index-type) - (nc-A (ncols A) :type index-type)) - (when (eq maj-A :row-major) - (rotatef nr-A nc-A)) - (,blas-gemv-func fop-a nr-A nc-A - alpha (store A) ld-A - (store x) (aref (strides x) 0) - beta - (store y) (aref (strides y) 0) - (head A) (head x) (head y))) - (,func alpha (,(getf opt :copy) A (,(getf opt :zero-maker) (dimensions A))) x beta y job))) - (t - ,lisp-routine))) - lisp-routine)) - y)))) - -;;Real -(generate-typed-gemv! real-base-typed-gemv! - (real-tensor dgemv *real-l2-fcall-lb*)) - -(definline real-typed-gemv! (alpha A x beta y job) - (real-base-typed-gemv! alpha A x beta y (ecase job ((:n :t) job) (:h :t) (:c :n)))) - -;;Complex -(generate-typed-gemv! complex-base-typed-gemv! - (complex-tensor zgemv *complex-l2-fcall-lb*)) - -(definline complex-typed-gemv! (alpha A x beta y job) - (declare (type complex-matrix A) - (type complex-vector x y) - (type complex-type alpha beta) - (type symbol job)) - (if (member job '(:n :t)) - (complex-base-typed-gemv! alpha A x beta y job) - ;; - (let-typed ((cx (let ((ret (complex-typed-copy! x (complex-typed-zeros (dimensions x))))) - (real-typed-num-scal! -1d0 (tensor-imagpart~ ret)) - ret) :type complex-vector) - (y.view (tensor-imagpart~ y))) - (real-typed-num-scal! -1d0 y.view) - (complex-base-typed-gemv! (cl:conjugate alpha) A cx - (cl:conjugate beta) y (ecase job (:h :t) (:c :n))) - (real-typed-num-scal! -1d0 y.view))) - y) +;;Witness the power of macros, muggles! :) +(deft/method t/gemv! (sym standard-tensor) (alpha A x beta y transp) + (using-gensyms (decl (alpha A x beta y transp)) + `(let (,@decl) + (declare (type ,sym ,A ,x ,y) + (type ,(field-type sym) ,alpha ,beta)) + (unless (t/f= ,(field-type sym) ,beta (t/fid* ,(field-type sym))) + (t/scdi! ,sym ,beta ,y :scal? t :numx? t)) + ;;These loops are optimized for column major matrices + (if ,transp + (einstein-sum ,sym (i j) (ref ,y i) (* ,alpha (ref ,A j i) (ref ,x j)) nil) + (einstein-sum ,sym (j i) (ref ,y i) (* ,alpha (ref ,A i j) (ref ,x j)) nil)) + ,y))) ;;Symbolic #+maxima (generate-typed-gemv! symbolic-base-typed-gemv! (symbolic-tensor nil 0)) - ;;---------------------------------------------------------------;; - (defgeneric gemv! (alpha A x beta y &optional job) (:documentation " diff --git a/src/utilities/macros.lisp b/src/utilities/macros.lisp index 738ab74..f19868f 100644 --- a/src/utilities/macros.lisp +++ b/src/utilities/macros.lisp @@ -462,6 +462,14 @@ Macro which encloses @arg{forms} inside (declare (optimize (speed 3) (safety 0) (space 0))) " + #+matlisp-debug + `(with-optimization + #+lispworks + (:safety 3) + #-lispworks + (:safety 3) + ,@forms) + #-matlisp-debug `(with-optimization #+lispworks (:safety 0 :space 0 :speed 3 :float 0 :fixnum-safety 0) diff --git a/tests/tcomp.lisp b/tests/tcomp.lisp index 36c0683..8f7e990 100644 --- a/tests/tcomp.lisp +++ b/tests/tcomp.lisp @@ -45,3 +45,11 @@ (aref sto-y i) (random 1d0)))) (time (mm-test x y z)) t) + +(defun mv-test (A b c) + (t/gemv! real-tensor 1d0 A b 0d0 c nil)) + +(let ((A (copy! #2a((1 2) (3 4)) (zeros '(2 2)))) + (b (copy! 1 (zeros 2))) + (c (copy! #(1 2) (zeros 2)))) + (time (dotimes (i 1000) (mv-test A b c)))) ----------------------------------------------------------------------- Summary of changes: matlisp.asd | 5 +- src/base/blas-helpers.lisp | 4 +- src/base/einstein.lisp | 7 +- src/base/template.lisp | 4 +- src/classes/numeric.lisp | 1 + src/level-1/axpy.lisp | 2 - src/level-1/dot.lisp | 6 - src/level-1/scal.lisp | 4 - src/level-2/gemv.lisp | 362 ++++++++++++-------------------------------- src/level-3/gemm.lisp | 306 ++++++------------------------------- src/utilities/macros.lisp | 8 + tests/tcomp.lisp | 27 ++++ 12 files changed, 193 insertions(+), 543 deletions(-) hooks/post-receive -- matlisp |
From: Akshay S. <ak...@us...> - 2013-08-10 05:22:02
|
This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "matlisp". The branch, classy has been updated via 228188fe426f884dd6a1743578e879350b7050ec (commit) from 03eedb3f3faa199ef9b76c30b95d4222d98dd9be (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 228188fe426f884dd6a1743578e879350b7050ec Author: Akshay Srinivasan <aks...@gm...> Date: Fri Aug 9 22:21:50 2013 -0700 Added routines for automatic loop-order generation. diff --git a/src/base/einstein.lisp b/src/base/einstein.lisp index 648d4f8..ac0ada7 100644 --- a/src/base/einstein.lisp +++ b/src/base/einstein.lisp @@ -18,7 +18,25 @@ (if (atom tlst) tlst (mapcar #'(lambda (x) (mapcons func x keys)) tlst))))) -(defun loop-generator (type index-order place clause &key (testp t) (tight-iloop nil)) +;;Only works for distinct objects +(defun generate-permutations (lst) + (if (null (cdr lst)) (list lst) + (apply #'append (mapcar #'(lambda (x) + (let ((pop-x (setrem lst x))) + (mapcar #'(lambda (y) (cons x y)) (generate-permutations pop-x)))) + lst)))) + +(defun set-eq (a b &key (test #'eql)) + (and (loop :for ele :in a + :do (unless (member ele b :test test) + (return nil)) + :finally (return t)) + (loop :for ele :in b + :do (unless (member ele a :test test) + (return nil)) + :finally (return t)))) + +(defun parse-loopx (type place clause) (let* ((refs (let ((tmp (get-cons (list place clause) 'ref)) (ret nil)) (loop :for ele :in tmp @@ -48,135 +66,177 @@ (if cdim (rplacd (last cdim) (cdr ipos)) (push ipos tmp)))) - (loop :for idx :in tmp - :do (assert (member (car idx) index-order) nil "Error index ~a not found in the index-order." (car idx))) - (loop :for idx :in index-order - :collect (let ((cdim (find idx tmp :key #'car))) - (assert (not (null cdim)) nil "Error index ~a not found in the expression." idx) - cdim)))) - (idx-d (let ((refrem (mapcons #'(lambda (x) (declare (ignore x)) t) - clause '(ref)))) - (remove-if #'null (mapcar #'(lambda (x) (when (has-sym refrem x) x)) (mapcar #'car indices)))))) - (labels ((get-prop (x &optional prop) - (let ((plst (find x tlist :key #'(lambda (x) (cadr (getf x :tensor)))))) - (if prop - (getf plst prop) - plst))) - (get-offset (x) - (caar (second (find (cdr x) (get-prop (car x) :offsets) :key #'car :test #'list-eq))))) - ;;Populate offsets - (loop :for ref :in refs - :do (let* ((plist (get-prop (second ref))) - (ofsym (gensym (string+ "offset-" (symbol-name (second (getf plist :tensor)))))) - (ret `((,ofsym ,(car (getf plist :head)) :type index-type) - (,(gensym (string+ "ref-" (symbol-name (second (getf plist :tensor))))) (t/store-ref ,type ,(car (getf plist :store)) ,ofsym) :type ,(field-type type))))) - (if (getf plist :offsets) - (setf (getf plist :offsets) (append (getf plist :offsets) (list (list (cddr ref) ret)))) - (rplacd (last plist) (list :offsets (list (list (cddr ref) ret))))))) - ;;Compute offset increments - (let ((rev (reverse indices))) - (labels ((get-incs (idxs acc decl incs ten ofst) - (if (null idxs) (values decl incs) - (let* ((clst (car idxs)) - (cidx (car clst)) - (idx-rem (mapcar #'car idxs)) - (tloop (and tight-iloop (eql cidx (car (last index-order)))))) - (cond - ((loop :for ele :in (car ofst) - :do (when (member ele idx-rem) - (return nil)) - :finally (return t)) - (values (append (make-list (length idxs)) decl) - (append (make-list (1- (length idxs))) (cons `(setf ,(caar (cadr ofst)) ,(car (get-prop ten :head))) incs)))) - (t - (let* ((plst (get-prop ten)) - (dsym (gensym (string+ "d-stp-" (symbol-name cidx) "-" (symbol-name ten)))) - (memp (member cidx (car ofst))) - (stp (when memp `(aref ,(car (getf plst :strides)) ,(position cidx (car ofst)))))) - (get-incs (cdr idxs) (if memp (list `(the index-type (* ,(if tloop 1 stp) (aref ,(car (getf plst :dimensions)) ,(position cidx (car ofst)))))) nil) - (if (or tloop (and (null acc) (not memp))) (cons nil decl) - (cons - (if memp - `(,dsym ,(if (null acc) stp `(the index-type (- ,stp ,@acc))) :type index-type) - `(,dsym (the index-type (- ,@acc)) :type index-type)) - decl)) - (if (and (null acc) (not memp)) (cons nil incs) - (cons `(incf ,(caar (cadr ofst)) ,@(unless tloop `(,dsym))) incs)) - ten ofst)))))))) - (mapcar #'(lambda (ten) - (loop :for ofst :in (get-prop ten :offsets) - :do (rplacd (last ofst) (multiple-value-list (get-incs rev nil nil nil ten ofst))))) - tens))) - ;; - (labels ((testgen () - `((assert (and ,@(mapcar #'(lambda (idx) - `(= ,@(mapcar #'(lambda (x) `(aref ,(car (get-prop (car x) :dimensions)) ,(cadr x))) (cdr idx)))) indices)) - nil "error: arguments are not of appropriate sizes.") - ,@(when tight-iloop - `((assert (= 1 ,@(mapcar #'(lambda (x) `(aref ,(car (get-prop (car x) :strides)) ,(cadr x))) (cdar (last indices)))) nil "error: Inner loop strides are not 1."))))) - (t/compile (place clause) - (let* ((cclause (mapcons #'(lambda (x) - (let* ((plst (get-prop (cadr x))) - (ofset-sym (get-offset (cdr x)))) - `(t/store-ref ,type ,(car (getf plst :store)) ,ofset-sym))) - clause '(ref))) - (ftype (field-type type))) - (setf cclause - (mapcons #'(lambda (x) - (let ((op (car x))) - `(,(case op (* 't/f*) (+ 't/f+) (- 't/f-) (/ 't/f/)) - ,ftype - ,@(cdr x)))) - cclause '(* + - /))) - (let ((plst (get-prop (cadr place))) - (valsym (gensym "value"))) - `((let-typed ((,valsym (t/f+ ,ftype (t/store-ref ,type ,(car (getf plst :store)) ,(get-offset (cdr place))) - ,cclause ) :type ,ftype)) - (t/store-set ,type ,valsym ,(car (getf plst :store)) ,(get-offset (cdr place)))))))) - (loopgen (idxs place clause) - (if (null idxs) (t/compile place clause) - (let ((cidx (caar idxs)) - (clst (car idxs))) - (let ((tdecl (let ((ilist (mapcar #'car idxs))) - (remove-if #'null - (apply #'append - (mapcar #'(lambda (ten) - (mapcar #'(lambda (ofs) - (when (loop :for idx :in (car ofs) - :do (when (member idx ilist) - (return nil)) - :finally (return t)) - (let ((decl (cadr (cadr ofs)))) - (setf clause (mapcons #'(lambda (x) - (if (and (eql (cadr x) ten) (equal (cddr x) (car ofs))) - (car decl) - x)) - clause '(ref))) - decl))) - (get-prop ten :offsets))) - (setrem tens (cadr place)))))))) - (list - (recursive-append - (unless (null tdecl) - `(let-typed (,@tdecl))) - `(loop ,@(let ((repl `(aref ,(car (get-prop (car (cadr clst)) :dimensions)) ,(cadr (cadr clst))))) - (if (member cidx idx-d) - `(:for ,cidx :of-type index-type :from 0 :below ,repl) - `(:repeat ,repl))) - :do (progn - ,@(loopgen (cdr idxs) place clause) - ,@(remove-if #'null (apply #'append - (mapcar #'(lambda (ten) (mapcar #'(lambda (x) (elt (fourth x) (position cidx index-order))) (get-prop ten :offsets))) tens)))))))))))) + tmp))) + (values refs tlist indices))) + +(defun loop-generator-base (type index-order place clause &key (testp t) (tight-iloop nil)) + (multiple-value-bind (refs tlist indices) (parse-loopx type place clause) + (let* ((tens (mapcar #'(lambda (x) (second (getf x :tensor))) tlist)) + (indices (progn + (loop :for idx :in indices + :do (assert (member (car idx) index-order) nil "Error index ~a not found in the index-order." (car idx))) + (loop :for idx :in index-order + :collect (let ((cdim (find idx indices :key #'car))) + (assert (not (null cdim)) nil "Error index ~a not found in the expression." idx) + cdim)))) + (idx-d (let ((refrem (mapcons #'(lambda (x) (declare (ignore x)) t) + clause '(ref)))) + (remove-if #'null (mapcar #'(lambda (x) (when (has-sym refrem x) x)) (mapcar #'car indices)))))) + (labels ((get-prop (x &optional prop) + (let ((plst (find x tlist :key #'(lambda (x) (cadr (getf x :tensor)))))) + (if prop + (getf plst prop) + plst))) + (get-offset (x) + (caar (second (find (cdr x) (get-prop (car x) :offsets) :key #'car :test #'list-eq))))) + ;;Populate offsets + (loop :for ref :in refs + :do (let* ((plist (get-prop (second ref))) + (ofsym (gensym (string+ "offset-" (symbol-name (second (getf plist :tensor)))))) + (ret `((,ofsym ,(car (getf plist :head)) :type index-type) + (,(gensym (string+ "ref-" (symbol-name (second (getf plist :tensor))))) (t/store-ref ,type ,(car (getf plist :store)) ,ofsym) :type ,(field-type type))))) + (if (getf plist :offsets) + (setf (getf plist :offsets) (append (getf plist :offsets) (list (list (cddr ref) ret)))) + (rplacd (last plist) (list :offsets (list (list (cddr ref) ret))))))) + ;;Compute offset increments + (let ((rev (reverse indices))) + (labels ((get-incs (idxs acc decl incs ten ofst) + (if (null idxs) (values decl incs) + (let* ((clst (car idxs)) + (cidx (car clst)) + (idx-rem (mapcar #'car idxs)) + (tloop (and tight-iloop (eql cidx (car (last index-order)))))) + (cond + ((loop :for ele :in (car ofst) + :do (when (member ele idx-rem) + (return nil)) + :finally (return t)) + (values (append (make-list (length idxs)) decl) + (append (make-list (1- (length idxs))) (cons `(setf ,(caar (cadr ofst)) ,(car (get-prop ten :head))) incs)))) + (t + (let* ((plst (get-prop ten)) + (dsym (gensym (string+ "d-stp-" (symbol-name cidx) "-" (symbol-name ten)))) + (memp (member cidx (car ofst))) + (stp (when memp `(aref ,(car (getf plst :strides)) ,(position cidx (car ofst)))))) + (get-incs (cdr idxs) (if memp (list `(the index-type (* ,(if tloop 1 stp) (aref ,(car (getf plst :dimensions)) ,(position cidx (car ofst)))))) nil) + (if (or tloop (and (null acc) (not memp))) (cons nil decl) + (cons + (if memp + `(,dsym ,(if (null acc) stp `(the index-type (- ,stp ,@acc))) :type index-type) + `(,dsym (the index-type (- ,@acc)) :type index-type)) + decl)) + (if (and (null acc) (not memp)) (cons nil incs) + (cons `(incf ,(caar (cadr ofst)) ,@(unless tloop `(,dsym))) incs)) + ten ofst)))))))) + (mapcar #'(lambda (ten) + (loop :for ofst :in (get-prop ten :offsets) + :do (rplacd (last ofst) (multiple-value-list (get-incs rev nil nil nil ten ofst))))) + tens))) ;; - `(locally - (declare (type ,type ,@tens)) - (let-typed (,@(apply #'append (mapcar #'(lambda (ten) (mapcar #'(lambda (prop) (get-prop ten prop)) '(:head :store :strides :dimensions))) tens))) - (let-typed (,@(apply #'append (mapcar #'(lambda (ten) (mapcar #'(lambda (x) (car (second x))) (get-prop ten :offsets))) tens)) - ,@(remove-if #'null (apply #'append (mapcar #'(lambda (ten) (apply #'append (mapcar #'third (get-prop ten :offsets)))) tens)))) - ,@(when testp (testgen)) - (very-quickly - ,@(loopgen indices place clause)))) - ,(cadr place)))))) + (labels ((testgen () + `((assert (and ,@(mapcar #'(lambda (idx) + `(= ,@(mapcar #'(lambda (x) `(aref ,(car (get-prop (car x) :dimensions)) ,(cadr x))) (cdr idx)))) indices)) + nil "error: arguments are not of appropriate sizes.") + ,@(when tight-iloop + `((assert (= 1 ,@(mapcar #'(lambda (x) `(aref ,(car (get-prop (car x) :strides)) ,(cadr x))) (cdar (last indices)))) nil "error: Inner loop strides are not 1."))))) + ;; + (t/compile (place clause) + (let* ((cclause (mapcons #'(lambda (x) + (let* ((plst (get-prop (cadr x))) + (ofset-sym (get-offset (cdr x)))) + `(t/store-ref ,type ,(car (getf plst :store)) ,ofset-sym))) + clause '(ref))) + (ftype (field-type type))) + (setf cclause + (mapcons #'(lambda (x) + (let ((op (car x))) + `(,(case op (* 't/f*) (+ 't/f+) (- 't/f-) (/ 't/f/)) + ,ftype + ,@(cdr x)))) + cclause '(* + - /))) + (let ((plst (get-prop (cadr place))) + (valsym (gensym "value"))) + `((let-typed ((,valsym (t/f+ ,ftype (t/store-ref ,type ,(car (getf plst :store)) ,(get-offset (cdr place))) + ,cclause ) :type ,ftype)) + (t/store-set ,type ,valsym ,(car (getf plst :store)) ,(get-offset (cdr place)))))))) + ;; + (loopgen (idxs place clause) + (if (null idxs) (t/compile place clause) + (let ((cidx (caar idxs)) + (clst (car idxs))) + (let ((tdecl (let ((ilist (mapcar #'car idxs))) + (remove-if #'null + (apply #'append + (mapcar #'(lambda (ten) + (mapcar #'(lambda (ofs) + (when (loop :for idx :in (car ofs) + :do (when (member idx ilist) + (return nil)) + :finally (return t)) + (let ((decl (cadr (cadr ofs)))) + (setf clause (mapcons #'(lambda (x) + (if (and (eql (cadr x) ten) (equal (cddr x) (car ofs))) + (car decl) + x)) + clause '(ref))) + decl))) + (get-prop ten :offsets))) + (setrem tens (cadr place)))))))) + (list + (recursive-append + (unless (null tdecl) + `(let-typed (,@tdecl))) + `(loop ,@(let ((repl `(aref ,(car (get-prop (car (cadr clst)) :dimensions)) ,(cadr (cadr clst))))) + (if (member cidx idx-d) + `(:for ,cidx :of-type index-type :from 0 :below ,repl) + `(:repeat ,repl))) + :do (progn + ,@(loopgen (cdr idxs) place clause) + ,@(remove-if #'null (apply #'append + (mapcar #'(lambda (ten) (mapcar #'(lambda (x) (elt (fourth x) (position cidx index-order))) (get-prop ten :offsets))) tens)))))))))))) + ;; + `(locally + (declare (type ,type ,@tens)) + (let-typed (,@(apply #'append (mapcar #'(lambda (ten) (mapcar #'(lambda (prop) (get-prop ten prop)) '(:head :store :strides :dimensions))) tens))) + (let-typed (,@(apply #'append (mapcar #'(lambda (ten) (mapcar #'(lambda (x) (car (second x))) (get-prop ten :offsets))) tens)) + ,@(remove-if #'null (apply #'append (mapcar #'(lambda (ten) (apply #'append (mapcar #'third (get-prop ten :offsets)))) tens)))) + ,@(when testp (testgen)) + (very-quickly + ,@(loopgen indices place clause)))) + ,(cadr place))))))) + +(defmacro einstein-sum-base (type idx-order place clause &optional (testp t) (tight-iloop nil)) + (loop-generator-base type idx-order place clause :testp testp :tight-iloop tight-iloop)) + +;;Push this code into loop-generator-base ? +(defun loop-generator (type index-order place clause &key (testp t)) + (multiple-value-bind (refs tlist indices) (parse-loopx type place clause) + (let ((in-idx (find (car (last index-order)) indices :key #'car))) + `(if (= 1 ,@(mapcar #'(lambda (x) `(aref (the index-store-vector (strides ,(car x))) ,(cadr x))) (cdr in-idx))) + ,(loop-generator-base type index-order place clause :testp testp :tight-iloop t) + ,(loop-generator-base type index-order place clause :testp testp :tight-iloop nil))))) + +(defmacro einstein-sum (type idx-order place clause &optional (testp t)) + (loop-generator type idx-order place clause :testp testp)) -(defmacro einstein-sum (type idx-order place clause &optional (tightp nil)) - (loop-generator type idx-order place clause :tight-iloop tightp)) +;;Yes this is slow, but if you're *really* worried about computation then roll your custom loops +;;with einstein-sum-base. This is a super-adaptive on-the-fly loop generation function generation +;;macro. You have the power now, without any of the tedium :) +(defmacro define-einstein-sum (name args (type place clause &optional (testp t))) + (multiple-value-bind (refs tlist indices) (parse-loopx type place clause) + (declare (ignore refs)) + (let ((tens (mapcar #'(lambda (x) (second (getf x :tensor))) tlist))) + (assert (set-eq tens args) nil "Error args and the list of tensor do not match.")) + (with-gensyms (functable) + `(let ((,functable (make-hash-table :test 'equal))) + (defun ,name (,@args) + (declare (type ,type ,@args)) + (let* ((idx-ord (mapcar #'car (very-quickly (sort (list ,@(mapcar #'(lambda (idx) `(list ',(car idx) (+ ,@(mapcar #'(lambda (x) `(aref (the index-store-vector (strides ,(car x))) ,(cadr x))) (cdr idx))))) indices)) #'(lambda (a b) (declare (type index-type a b)) (> a b)) :key #'cadr)))) + (func (or (gethash idx-ord ,functable) + (let* ((code (loop-generator ',type idx-ord ',place ',clause :testp ,testp)) + (funcnew (compile-and-eval + (list 'lambda '(,@args) code)))) + (format t "Compiling code for index-order : ~a~%" idx-ord) + (setf (gethash idx-ord ,functable) funcnew) + funcnew)))) + (apply func (list ,@args)))))))) diff --git a/tests/loopy-tests.lisp b/tests/loopy-tests.lisp index b7ad434..cceb145 100644 --- a/tests/loopy-tests.lisp +++ b/tests/loopy-tests.lisp @@ -156,6 +156,54 @@ (setf of-B hd-B)))))) t))) +(defun test-mm-lisp-blk (n bs) + (declare (type fixnum n)) + (let ((*default-stride-ordering* :row-major)) + (let ((A (zeros (list n n))) + (B (zeros (list n n))) + (C (zeros (list n n)))) + (let-typed ((nr-C (nrows C) :type index-type) + (nc-C (ncols C) :type index-type) + (dotl (ncols A) :type index-type) + ; + (rstp-A (row-stride A) :type index-type) + (cstp-A (col-stride A) :type index-type) + (hd-A (head A) :type index-type) + (sto-A (store A) :type real-store-vector) + ; + (rstp-B (row-stride B) :type index-type) + (cstp-B (col-stride B) :type index-type) + (hd-B (head B) :type index-type) + (sto-B (store B) :type real-store-vector) + ; + (rstp-C (row-stride C) :type index-type) + (cstp-C (col-stride C) :type index-type) + (hd-C (head C) :type index-type) + (sto-C (store C) :type real-store-vector)) + (time + (let-typed ((of-A hd-A :type index-type) + (of-B hd-B :type index-type) + (of-C hd-C :type index-type) + (r.cstp-C (* cstp-C nc-C) :type index-type) + (d.rstp-B (- rstp-B (* cstp-B nc-C)) :type index-type) + (d.rstp-A (- rstp-A (* cstp-A dotl)) :type index-type)) + (very-quickly + (loop :repeat (floor nr-C bs) + :do (progn + (loop :repeat (floor dotl bs) + :do (loop :repeat (min ( (let-typed ((ele-A (aref sto-A of-A) :type real-type)) + (loop :repeat nc-C + :do (progn + (incf (aref sto-C of-C) (* ele-A (aref sto-B of-B))) + (incf of-C #+nil cstp-C) + (incf of-B #+nil cstp-B))) + (decf of-C r.cstp-C) + (incf of-A cstp-A) + (incf of-B d.rstp-B))) + (incf of-C (* rstp-C bs)) + (incf of-A d.rstp-A) + (setf of-B hd-B)))))) + t)))) (defun test-mm-lisp-lin (n) (declare (type fixnum n)) diff --git a/tests/tcomp.lisp b/tests/tcomp.lisp new file mode 100644 index 0000000..36c0683 --- /dev/null +++ b/tests/tcomp.lisp @@ -0,0 +1,47 @@ +(in-package :matlisp) + +(defparameter *tclause* '(einstein-sum (ref C i j) (* (ref A i k) (ref A j k)))) +(defparameter *mclause* '(einstein-sum (ref C i j) (* (ref A i k) (ref B k j)))) + +(loop-generator 'real-tensor '(k j i) (second *tclause*) (third *tclause*)) +(loop-generator 'real-tensor '(i j k) (second *mclause*) (third *mclause*) :tight-iloop t) + +(defun mm-test-simple (a b c) + (declare (type real-tensor a b c)) + (einstein-sum real-tensor (j k i) (ref c i j) (* (ref a i k) (ref b k j)))) + +(define-einstein-sum mm-test (a b c) (real-tensor (ref c i j) (* (ref a i k) (ref b k j)))) + +(let ((thingy #'(lambda (a b c) (einstein-sum real-tensor (j k i) (ref c i j) (* (ref a i k) (ref b k j)))))) + (let ((x (copy! #2a((1 2) (3 4)) (zeros '(2 2)))) + (y (copy! #2a((4 5) (6 5)) (zeros '(2 2)))) + (z (zeros '(2 2)))) + (time (dotimes (i 1000) (funcall thingy x y z))))) + +(defun mat-square (a c) + (einstein-sum real-tensor (j k i) (ref c i j) (* (ref a i k) (ref a k j)) t)) + +(let ((x (copy! #2a((1 2) (3 4)) (zeros '(2 2)))) + (y (copy! #2a((4 5) (6 5)) (zeros '(2 2)))) + (z (zeros '(2 2)))) + (time + (dotimes (i 1000) + (copy! 0 z) + (mm-test x y z))) + (print (mm-test x y (zeros '(2 2) 'real-tensor)))) + +(let ((x (copy! #2a((1 2) (3 4)) (zeros '(2 2)))) + (y (copy! #2a((4 5) (6 5)) (zeros '(2 2)))) + (z (zeros '(2 2)))) + (time (mm-test x y z))) + +(let ((x (zeros '(1000 1000))) + (y (transpose! (zeros '(1000 1000)))) + (z (zeros '(1000 1000)))) + (let-typed ((sto-x (store x) :type (simple-array double-float)) + (sto-y (store y) :type (simple-array double-float))) + (loop :for i :from 0 :below (array-dimension sto-x 0) + :do (setf (aref sto-x i) (random 1d0) + (aref sto-y i) (random 1d0)))) + (time (mm-test x y z)) + t) ----------------------------------------------------------------------- Summary of changes: src/base/einstein.lisp | 322 ++++++++++++++++++++++++++++-------------------- tests/loopy-tests.lisp | 48 +++++++ tests/tcomp.lisp | 47 +++++++ 3 files changed, 286 insertions(+), 131 deletions(-) create mode 100644 tests/tcomp.lisp hooks/post-receive -- matlisp |
From: Akshay S. <ak...@us...> - 2013-07-22 17:17:11
|
This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "matlisp". The branch, classy has been updated via 03eedb3f3faa199ef9b76c30b95d4222d98dd9be (commit) via 7e8e80cf438552059d8d05797da5a4f9320127d3 (commit) via 222aee503ad0678516eaae1e638b016fb01efb09 (commit) via 5f237cd125d3d50ae322fdeaf1db314f0562830e (commit) from 95d41cef90f67e4d0b50ca7679ce5b5bffdd7532 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 03eedb3f3faa199ef9b76c30b95d4222d98dd9be Author: Akshay Srinivasan <aks...@gm...> Date: Sun Jul 21 23:20:56 2013 -0700 Fixed the return in the incf computer. diff --git a/src/base/einstein.lisp b/src/base/einstein.lisp index cdadac9..648d4f8 100644 --- a/src/base/einstein.lisp +++ b/src/base/einstein.lisp @@ -86,9 +86,8 @@ :do (when (member ele idx-rem) (return nil)) :finally (return t)) - (get-incs nil acc (cons nil decl) - (cons `(setf ,(caar (cadr ofst)) ,(car (get-prop ten :head))) incs) - ten ofst)) + (values (append (make-list (length idxs)) decl) + (append (make-list (1- (length idxs))) (cons `(setf ,(caar (cadr ofst)) ,(car (get-prop ten :head))) incs)))) (t (let* ((plst (get-prop ten)) (dsym (gensym (string+ "d-stp-" (symbol-name cidx) "-" (symbol-name ten)))) commit 7e8e80cf438552059d8d05797da5a4f9320127d3 Author: Akshay Srinivasan <aks...@gm...> Date: Sun Jul 21 23:02:47 2013 -0700 Cleanups to einstein.lisp. diff --git a/matlisp.asd b/matlisp.asd index 08ce377..71aa515 100644 --- a/matlisp.asd +++ b/matlisp.asd @@ -112,6 +112,8 @@ ;; (:file "loopy" :depends-on ("standard-tensor")) + (:file "einstein" + :depends-on ("standard-tensor")) (:file "generic-copy" :depends-on ("standard-tensor" "loopy")) (:file "generic-swap" diff --git a/src/base/tensor-comprehension.lisp b/src/base/einstein.lisp similarity index 79% rename from src/base/tensor-comprehension.lisp rename to src/base/einstein.lisp index f33a780..cdadac9 100644 --- a/src/base/tensor-comprehension.lisp +++ b/src/base/einstein.lisp @@ -1,12 +1,5 @@ (in-package :matlisp) -(defparameter *contract-ops* '(sum)) - -;;(defparameter *tgemv* '(contract (ref y i) (+ (* alpha (sum (k) (ref A i k) (ref x k))) (* beta (ref y i))))) - -(defparameter *tclause* '(einstein-sum (ref C i j) (* (ref A i k) (ref A j k)))) -(defparameter *mclause* '(einstein-sum (ref C i j) (* (ref A i k) (ref B k j)))) - (defun get-cons (lst sym) (if (atom lst) nil (if (eq (car lst) sym) @@ -17,17 +10,6 @@ (if (atom lst) (eql lst sym) (or (has-sym (car lst) sym) (has-sym (cdr lst) sym)))) -(defun get-repeats (lst) - (do ((tmp lst (cdr tmp)) - (ret nil (if (and (not (member (car tmp) ret)) (member (car tmp) (cdr tmp))) - (cons (car tmp) ret) - ret))) - ((null tmp) ret))) - -(defun gensym-list (n) - (loop :repeat n :collect (gensym))) - - (defun mapcons (func lst keys) (if (atom lst) lst (let ((tlst (if (member (car lst) keys) @@ -36,29 +18,20 @@ (if (atom tlst) tlst (mapcar #'(lambda (x) (mapcons func x keys)) tlst))))) -#+nil -(mapcons #'(lambda (x) (let ((op (car x))) - `(,(case op (* 't/f*) (+ 't/f+) (- 't/f-) (/ 't/f/)) - double-float - ,@(cdr x)))) - '(* a (+ (ref a i j) c)) '(* + - /)) -#+nil -(mapcons #'(lambda (x) t) - '(* a (+ (ref a i j) c)) '(ref)) - - (defun loop-generator (type index-order place clause &key (testp t) (tight-iloop nil)) (let* ((refs (let ((tmp (get-cons (list place clause) 'ref)) (ret nil)) (loop :for ele :in tmp - :do (setf ret (setadd ret ele #'equal))) + :do (setf ret (setadd ret ele #'equal))) ret)) (tens (let ((ret nil)) (loop :for ele :in refs - :do (setf ret (setadd ret (second ele)))) + :do (setf ret (setadd ret (if (symbolp (second ele)) + (second ele) + (error "error: tensor argument is not a symbol."))))) ret)) (tlist (mapcar #'(lambda (sym) - (let* ((gsym (gensym (symbol-name sym))) + (let* ((gsym sym) (hsym (gensym (string+ "head-" (symbol-name sym))))) `(:tensor (,gsym ,sym :type ,type) :head (,hsym (head ,gsym) :type index-type) @@ -196,37 +169,15 @@ ,@(remove-if #'null (apply #'append (mapcar #'(lambda (ten) (mapcar #'(lambda (x) (elt (fourth x) (position cidx index-order))) (get-prop ten :offsets))) tens)))))))))))) ;; - `(let-typed (,@(mapcar #'(lambda (ten) (get-prop ten :tensor)) tens)) + `(locally + (declare (type ,type ,@tens)) (let-typed (,@(apply #'append (mapcar #'(lambda (ten) (mapcar #'(lambda (prop) (get-prop ten prop)) '(:head :store :strides :dimensions))) tens))) (let-typed (,@(apply #'append (mapcar #'(lambda (ten) (mapcar #'(lambda (x) (car (second x))) (get-prop ten :offsets))) tens)) ,@(remove-if #'null (apply #'append (mapcar #'(lambda (ten) (apply #'append (mapcar #'third (get-prop ten :offsets)))) tens)))) ,@(when testp (testgen)) (very-quickly - ,@(loopgen indices place clause))))))))) - -(loop-generator 'real-tensor '(k j i) (second *tclause*) (third *tclause*)) -(loop-generator 'real-tensor '(i j k) (second *mclause*) (third *mclause*) :tight-iloop t) - - -(defmacro einstein-sum (type idx-order place clause) - (loop-generator type idx-order place clause :tight-iloop t)) - -(defun mm-test (a b c) - (einstein-sum real-tensor (j k i) (ref c i j) (* (ref a i k) (ref b k j)))) - -(let ((x (copy! #2a((1 2) (3 4)) (zeros '(2 2)))) - (y (copy! #2a((4 5) (6 5)) (zeros '(2 2)))) - (z (zeros '(2 2)))) - (mm-test x y z) - z) + ,@(loopgen indices place clause)))) + ,(cadr place)))))) -(let ((x (zeros '(1000 1000))) - (y (zeros '(1000 1000))) - (z (zeros '(1000 1000)))) - (let-typed ((sto-x (store x) :type (simple-array double-float)) - (sto-y (store y) :type (simple-array double-float))) - (loop :for i :from 0 :below (* 1000 1000) - :do (setf (aref sto-x i) (random 1d0) - (aref sto-y i) (random 1d0)))) - (time (mm-test x y z)) - t) +(defmacro einstein-sum (type idx-order place clause &optional (tightp nil)) + (loop-generator type idx-order place clause :tight-iloop tightp)) commit 222aee503ad0678516eaae1e638b016fb01efb09 Author: Akshay Srinivasan <aks...@gm...> Date: Sun Jul 21 17:52:33 2013 -0700 finished writing a very cool einstein summation macro :) diff --git a/src/base/tensor-comprehension.lisp b/src/base/tensor-comprehension.lisp index a0fdc73..f33a780 100644 --- a/src/base/tensor-comprehension.lisp +++ b/src/base/tensor-comprehension.lisp @@ -4,7 +4,8 @@ ;;(defparameter *tgemv* '(contract (ref y i) (+ (* alpha (sum (k) (ref A i k) (ref x k))) (* beta (ref y i))))) -(defparameter *tclause* '(einstein-sum (ref C i j) (* (ref A i k) (ref B k j)))) +(defparameter *tclause* '(einstein-sum (ref C i j) (* (ref A i k) (ref A j k)))) +(defparameter *mclause* '(einstein-sum (ref C i j) (* (ref A i k) (ref B k j)))) (defun get-cons (lst sym) (if (atom lst) nil @@ -12,6 +13,10 @@ (list lst) (append (get-cons (car lst) sym) (get-cons (cdr lst) sym))))) +(defun has-sym (lst sym) + (if (atom lst) (eql lst sym) + (or (has-sym (car lst) sym) (has-sym (cdr lst) sym)))) + (defun get-repeats (lst) (do ((tmp lst (cdr tmp)) (ret nil (if (and (not (member (car tmp) ret)) (member (car tmp) (cdr tmp))) @@ -22,126 +27,206 @@ (defun gensym-list (n) (loop :repeat n :collect (gensym))) -#+nil -(defun loop-gen (idx ret einx) - (if (null idx) code - (destructuring-bind (var repeat) (car idx) - `(loop :for ,var :of-type index-type :from ,start :below ,end - :do ,(loop-gen (cdr idx) code))))) - -(tensor-args (get-cons (cddr clause) 'ref)) - (code-idx (get-repeats (apply #'append (mapcar #'cddr tensor-args)))) - (arg-idx (let ((ret nil)) - (mapcar #'(lambda (x) (if (symbolp x) (setf ret (setadd ret x)))) (cddr arg)) - ret)) - (idxs (append arg-idx code-idx)) - (dims (apply #'append (mapcar #'(lambda (x) (loop :for idx :in (cddr x) - :counting t :into i - :when (member idx idxs) - :collect `(,idx (aref (dimensions ,(cadr x)) ,(1- i))))) tensor-args))) - - (osyms (zipsym (mapcar #'(lambda (x) `(head ,(car x))) tsyms))) - (stosyms (zipsym (mapcar #'(lambda (x) `(store ,(car x))) tsyms))) - (stdsyms (zipsym (mapcar #'(lambda (x) `(strides ,(car x))) tsyms))) - (dimsyms (zipsym (mapcar #'(lambda (x) `(dimensions ,(car x))) tsyms)))) - (defun mapcons (func lst keys) - (cond - ((atom lst) lst) - ((member (car lst) keys) - (funcall func lst)) - (t - (mapcar #'(lambda (x) (mapcons func x keys)) lst)))) - -(mapcons #'(lambda (x) `(aref (store ,(cadr x)) ,@(cddr x))) - *tclause* '(ref)) - - - (loopgen (idxs cclause place &optional (start? t)) - `(loop - :with ... :of-type index-type := ... - :with ... :of-type index-type := ... - :for (car idxs) :of-type index-type :from 0 :below - - )) - - -(defun loop-generator (type clause &optional (testp t)) - (let* ((ten-syms (mapcar #'(lambda (x) - (let* ((sym (second x)) - (gsym (gensym (symbol-name sym)))) - `((,gsym ,sym) - (,(gensym (string+ "head-" (symbol-name sym))) (head ,gsym)) - (,(gensym (string+ "store-" (symbol-name sym))) (store ,gsym)) - (,(gensym (string+ "strides-" (symbol-name sym))) (strides ,gsym)) - (,(gensym (string+ "dimensions-" (symbol-name sym))) (dimensions ,gsym))))) - (get-cons (cdr clause) 'ref))) - (offsets nil) - (ranges nil)) - (labels ((get-plst (x) - (find x ten-syms :key #'cadar :test #'eql)) + (if (atom lst) lst + (let ((tlst (if (member (car lst) keys) + (funcall func lst) + lst))) + (if (atom tlst) tlst + (mapcar #'(lambda (x) (mapcons func x keys)) tlst))))) + +#+nil +(mapcons #'(lambda (x) (let ((op (car x))) + `(,(case op (* 't/f*) (+ 't/f+) (- 't/f-) (/ 't/f/)) + double-float + ,@(cdr x)))) + '(* a (+ (ref a i j) c)) '(* + - /)) +#+nil +(mapcons #'(lambda (x) t) + '(* a (+ (ref a i j) c)) '(ref)) + + +(defun loop-generator (type index-order place clause &key (testp t) (tight-iloop nil)) + (let* ((refs (let ((tmp (get-cons (list place clause) 'ref)) + (ret nil)) + (loop :for ele :in tmp + :do (setf ret (setadd ret ele #'equal))) + ret)) + (tens (let ((ret nil)) + (loop :for ele :in refs + :do (setf ret (setadd ret (second ele)))) + ret)) + (tlist (mapcar #'(lambda (sym) + (let* ((gsym (gensym (symbol-name sym))) + (hsym (gensym (string+ "head-" (symbol-name sym))))) + `(:tensor (,gsym ,sym :type ,type) + :head (,hsym (head ,gsym) :type index-type) + :store (,(gensym (string+ "store-" (symbol-name sym))) (store ,gsym) :type ,(store-type type)) + :strides (,(gensym (string+ "strides-" (symbol-name sym))) (strides ,gsym) :type index-store-vector) + :dimensions (,(gensym (string+ "dimensions-" (symbol-name sym))) (dimensions ,gsym) :type index-store-vector)))) + tens)) + (indices (let ((tmp nil) + (idx-pos (apply #'append (mapcar #'(lambda (x) (loop :for ele :in (cddr x) + :counting t :into i + :collect `(,ele (,(cadr x) ,(1- i))))) refs)))) + (loop :for ipos :in idx-pos + :do (let ((cdim (find (car ipos) tmp :key #'car))) + (if cdim + (rplacd (last cdim) (cdr ipos)) + (push ipos tmp)))) + (loop :for idx :in tmp + :do (assert (member (car idx) index-order) nil "Error index ~a not found in the index-order." (car idx))) + (loop :for idx :in index-order + :collect (let ((cdim (find idx tmp :key #'car))) + (assert (not (null cdim)) nil "Error index ~a not found in the expression." idx) + cdim)))) + (idx-d (let ((refrem (mapcons #'(lambda (x) (declare (ignore x)) t) + clause '(ref)))) + (remove-if #'null (mapcar #'(lambda (x) (when (has-sym refrem x) x)) (mapcar #'car indices)))))) + (labels ((get-prop (x &optional prop) + (let ((plst (find x tlist :key #'(lambda (x) (cadr (getf x :tensor)))))) + (if prop + (getf plst prop) + plst))) (get-offset (x) - (let ((ofst (find x offsets :key #'cadr :test #'equal))) - (if ofst - (car ofst) - (let ((ofsym (gensym (string+ "offset-" (symbol-name (car x)))))) - (push (list ofsym x) offsets) - ofsym)))) - (testgen () - (let ((dims (apply #'append (mapcar #'(lambda (x) (loop :for ele :in (cdr (cadr x)) - :counting t :into i - :collect (let ((plst (get-plst (car (cadr x))))) - `(,ele (aref ,(car (elt plst 4)) ,(1- i)))))) offsets)))) - (loop :for ele :in dims - :do (let ((cdim (find (car ele) ranges :key #'car :test #'eql))) - (if cdim - (rplacd (last cdim) (cdr ele)) - (push ele ranges)))) - (when testp - `((assert (and ,@(mapcar #'(lambda (x) `(= ,@(cdr x))) ranges)) nil "error: arguments are not of appropriate sizes."))))) - (loopgen (idxs place clause &optional (startp t)) - (let ((cidx (caar idxs))) - `((let*-typed (,@(remove-if #'null - (mapcar #'(lambda (x) - (if (or (member cidx (cdr (cadr x))) startp) - (let ((offset (gensym (string+ "of-" (symbol-name cidx) "-" (symbol-name (car (cadr x))))))) - `(:with ,offset :of-type index-type := ... - :for ,(car x) :of-type index-type := ,(if startp - (let ((plst (get-plst (car (cadr x))))) - (car (elt plst 1))) - (car x)) - :then (the index-type (+ ,offset ,(car x)))) - nil)) - offsets))) - - (loop - :for ,cidx :of-type index-type :from 0 :below ,(cadr (car idxs)) - ,@(apply #'append (remove-if #'null (mapcar #'(lambda (x) - (if (or (member cidx (cdr (cadr x))) startp) - (let ((offset (gensym (string+ "of-" (symbol-name cidx) "-" (symbol-name (car (cadr x))))))) - `(:with ,offset :of-type index-type := ... - :for ,(car x) :of-type index-type := ,(if startp - (let ((plst (get-plst (car (cadr x))))) - (car (elt plst 1))) - (car x)) - :then (the index-type (+ ,offset ,(car x)))) - nil)) - offsets))) - ))))) - (let* ((cclause (mapcons #'(lambda (x) - (let* ((plst (get-plst (cadr x))) - (ofset-sym (get-offset (cdr x)))) - `(t/store-ref ,type ,(caaddr plst) ,ofset-sym))) - clause '(ref)))) - `(let (,@(mapcar #'car ten-syms)) - (declare (type ,type ,@(mapcar #'caar ten-syms))) - (let (,@(apply #'append (mapcar #'cdr ten-syms))) - (declare (type index-type ,@(mapcar #'caadr ten-syms)) - (type ,(store-type type) ,@(mapcar #'caaddr ten-syms)) - (type index-store-vector ,@(mapcar #'car (apply #'append (mapcar #'cdddr ten-syms))))) - ,@(testgen) - ,@(loopgen ranges (cadr cclause) (caddr cclause) t))))))) - - -(loop-generator 'real-tensor *tclause*) + (caar (second (find (cdr x) (get-prop (car x) :offsets) :key #'car :test #'list-eq))))) + ;;Populate offsets + (loop :for ref :in refs + :do (let* ((plist (get-prop (second ref))) + (ofsym (gensym (string+ "offset-" (symbol-name (second (getf plist :tensor)))))) + (ret `((,ofsym ,(car (getf plist :head)) :type index-type) + (,(gensym (string+ "ref-" (symbol-name (second (getf plist :tensor))))) (t/store-ref ,type ,(car (getf plist :store)) ,ofsym) :type ,(field-type type))))) + (if (getf plist :offsets) + (setf (getf plist :offsets) (append (getf plist :offsets) (list (list (cddr ref) ret)))) + (rplacd (last plist) (list :offsets (list (list (cddr ref) ret))))))) + ;;Compute offset increments + (let ((rev (reverse indices))) + (labels ((get-incs (idxs acc decl incs ten ofst) + (if (null idxs) (values decl incs) + (let* ((clst (car idxs)) + (cidx (car clst)) + (idx-rem (mapcar #'car idxs)) + (tloop (and tight-iloop (eql cidx (car (last index-order)))))) + (cond + ((loop :for ele :in (car ofst) + :do (when (member ele idx-rem) + (return nil)) + :finally (return t)) + (get-incs nil acc (cons nil decl) + (cons `(setf ,(caar (cadr ofst)) ,(car (get-prop ten :head))) incs) + ten ofst)) + (t + (let* ((plst (get-prop ten)) + (dsym (gensym (string+ "d-stp-" (symbol-name cidx) "-" (symbol-name ten)))) + (memp (member cidx (car ofst))) + (stp (when memp `(aref ,(car (getf plst :strides)) ,(position cidx (car ofst)))))) + (get-incs (cdr idxs) (if memp (list `(the index-type (* ,(if tloop 1 stp) (aref ,(car (getf plst :dimensions)) ,(position cidx (car ofst)))))) nil) + (if (or tloop (and (null acc) (not memp))) (cons nil decl) + (cons + (if memp + `(,dsym ,(if (null acc) stp `(the index-type (- ,stp ,@acc))) :type index-type) + `(,dsym (the index-type (- ,@acc)) :type index-type)) + decl)) + (if (and (null acc) (not memp)) (cons nil incs) + (cons `(incf ,(caar (cadr ofst)) ,@(unless tloop `(,dsym))) incs)) + ten ofst)))))))) + (mapcar #'(lambda (ten) + (loop :for ofst :in (get-prop ten :offsets) + :do (rplacd (last ofst) (multiple-value-list (get-incs rev nil nil nil ten ofst))))) + tens))) + ;; + (labels ((testgen () + `((assert (and ,@(mapcar #'(lambda (idx) + `(= ,@(mapcar #'(lambda (x) `(aref ,(car (get-prop (car x) :dimensions)) ,(cadr x))) (cdr idx)))) indices)) + nil "error: arguments are not of appropriate sizes.") + ,@(when tight-iloop + `((assert (= 1 ,@(mapcar #'(lambda (x) `(aref ,(car (get-prop (car x) :strides)) ,(cadr x))) (cdar (last indices)))) nil "error: Inner loop strides are not 1."))))) + (t/compile (place clause) + (let* ((cclause (mapcons #'(lambda (x) + (let* ((plst (get-prop (cadr x))) + (ofset-sym (get-offset (cdr x)))) + `(t/store-ref ,type ,(car (getf plst :store)) ,ofset-sym))) + clause '(ref))) + (ftype (field-type type))) + (setf cclause + (mapcons #'(lambda (x) + (let ((op (car x))) + `(,(case op (* 't/f*) (+ 't/f+) (- 't/f-) (/ 't/f/)) + ,ftype + ,@(cdr x)))) + cclause '(* + - /))) + (let ((plst (get-prop (cadr place))) + (valsym (gensym "value"))) + `((let-typed ((,valsym (t/f+ ,ftype (t/store-ref ,type ,(car (getf plst :store)) ,(get-offset (cdr place))) + ,cclause ) :type ,ftype)) + (t/store-set ,type ,valsym ,(car (getf plst :store)) ,(get-offset (cdr place)))))))) + (loopgen (idxs place clause) + (if (null idxs) (t/compile place clause) + (let ((cidx (caar idxs)) + (clst (car idxs))) + (let ((tdecl (let ((ilist (mapcar #'car idxs))) + (remove-if #'null + (apply #'append + (mapcar #'(lambda (ten) + (mapcar #'(lambda (ofs) + (when (loop :for idx :in (car ofs) + :do (when (member idx ilist) + (return nil)) + :finally (return t)) + (let ((decl (cadr (cadr ofs)))) + (setf clause (mapcons #'(lambda (x) + (if (and (eql (cadr x) ten) (equal (cddr x) (car ofs))) + (car decl) + x)) + clause '(ref))) + decl))) + (get-prop ten :offsets))) + (setrem tens (cadr place)))))))) + (list + (recursive-append + (unless (null tdecl) + `(let-typed (,@tdecl))) + `(loop ,@(let ((repl `(aref ,(car (get-prop (car (cadr clst)) :dimensions)) ,(cadr (cadr clst))))) + (if (member cidx idx-d) + `(:for ,cidx :of-type index-type :from 0 :below ,repl) + `(:repeat ,repl))) + :do (progn + ,@(loopgen (cdr idxs) place clause) + ,@(remove-if #'null (apply #'append + (mapcar #'(lambda (ten) (mapcar #'(lambda (x) (elt (fourth x) (position cidx index-order))) (get-prop ten :offsets))) tens)))))))))))) + ;; + `(let-typed (,@(mapcar #'(lambda (ten) (get-prop ten :tensor)) tens)) + (let-typed (,@(apply #'append (mapcar #'(lambda (ten) (mapcar #'(lambda (prop) (get-prop ten prop)) '(:head :store :strides :dimensions))) tens))) + (let-typed (,@(apply #'append (mapcar #'(lambda (ten) (mapcar #'(lambda (x) (car (second x))) (get-prop ten :offsets))) tens)) + ,@(remove-if #'null (apply #'append (mapcar #'(lambda (ten) (apply #'append (mapcar #'third (get-prop ten :offsets)))) tens)))) + ,@(when testp (testgen)) + (very-quickly + ,@(loopgen indices place clause))))))))) + +(loop-generator 'real-tensor '(k j i) (second *tclause*) (third *tclause*)) +(loop-generator 'real-tensor '(i j k) (second *mclause*) (third *mclause*) :tight-iloop t) + + +(defmacro einstein-sum (type idx-order place clause) + (loop-generator type idx-order place clause :tight-iloop t)) + +(defun mm-test (a b c) + (einstein-sum real-tensor (j k i) (ref c i j) (* (ref a i k) (ref b k j)))) + +(let ((x (copy! #2a((1 2) (3 4)) (zeros '(2 2)))) + (y (copy! #2a((4 5) (6 5)) (zeros '(2 2)))) + (z (zeros '(2 2)))) + (mm-test x y z) + z) + +(let ((x (zeros '(1000 1000))) + (y (zeros '(1000 1000))) + (z (zeros '(1000 1000)))) + (let-typed ((sto-x (store x) :type (simple-array double-float)) + (sto-y (store y) :type (simple-array double-float))) + (loop :for i :from 0 :below (* 1000 1000) + :do (setf (aref sto-x i) (random 1d0) + (aref sto-y i) (random 1d0)))) + (time (mm-test x y z)) + t) diff --git a/tests/loopy-tests.lisp b/tests/loopy-tests.lisp index ece1513..b7ad434 100644 --- a/tests/loopy-tests.lisp +++ b/tests/loopy-tests.lisp @@ -1,3 +1,4 @@ +(in-package :matlisp) (defun tdcopy (n) (let* ((t-a (make-real-tensor-dims n n n)) @@ -36,9 +37,9 @@ (make-array (length dims) :element-type 'index-type :initial-contents dims)) (defun test-mm-lisp (n) - (let ((t-a (make-real-tensor n n)) - (t-b (make-real-tensor n n)) - (t-c (make-real-tensor n n))) + (let ((t-a (zeros (list n n))) + (t-b (zeros (list n n))) + (t-c (zeros (list n n)))) (declare (type real-tensor t-a t-b t-c)) (let ((st-a (store t-a)) (st-b (store t-b)) @@ -55,7 +56,7 @@ (hd-a (head t-a)) (hd-b (head t-b)) (hd-c (head t-c))) - (declare (type real-store-vector st-a st-b st-c) + (declare (type (simple-array double-float (*)) st-a st-b st-c) (type index-type rstrd-a cstrd-a rstrd-b cstrd-b rstrd-c cstrd-c nr-c nc-c nc-a hd-a hd-b hd-c)) (mod-dotimes (idx (dimensions t-a)) @@ -77,7 +78,7 @@ do (loop repeat nc-a for of-a of-type index-type = rof-a then (+ of-a cstrd-a) for of-b of-type index-type = cof-b then (+ of-b rstrd-b) - summing (* (aref st-a of-a) (aref st-b of-b)) into sum of-type real-type + summing (* (aref st-a of-a) (aref st-b of-b)) into sum of-type double finally (setf (aref st-c of-c) sum)))) #+nil (mod-dotimes (idx (dimensions t-c)) @@ -101,12 +102,17 @@ do (incf (aref st-c of-c) (* (aref st-a of-a) (aref st-b of-b)))))) (values t-a t-b t-c)))) +(deftype real-store-vector () + '(simple-array double-float (*))) + +(deftype real-type () + 'double-float) (defun test-mm-lisp (n) (declare (type fixnum n)) - (let ((A (make-real-tensor n n)) - (B (make-real-tensor n n)) - (C (make-real-tensor n n))) + (let ((A (zeros (list n n))) + (B (zeros (list n n))) + (C (zeros (list n n)))) (let-typed ((nr-C (nrows C) :type index-type) (nc-C (ncols C) :type index-type) (dotl (ncols A) :type index-type) @@ -140,8 +146,8 @@ (loop :repeat nc-C :do (progn (incf (aref sto-C of-C) (* ele-A (aref sto-B of-B))) - (incf of-C cstp-C) - (incf of-B cstp-B))) + (incf of-C #+nil cstp-C) + (incf of-B #+nil cstp-B))) (decf of-C r.cstp-C) (incf of-A cstp-A) (incf of-B d.rstp-B))) @@ -150,6 +156,7 @@ (setf of-B hd-B)))))) t))) + (defun test-mm-lisp-lin (n) (declare (type fixnum n)) (let ((A (make-real-tensor n n)) commit 5f237cd125d3d50ae322fdeaf1db314f0562830e Author: Akshay Srinivasan <aks...@gm...> Date: Thu Jul 18 13:45:43 2013 -0700 Saving work on the tensor-comprehension feature. diff --git a/matlisp.asd b/matlisp.asd index c28a1f4..08ce377 100644 --- a/matlisp.asd +++ b/matlisp.asd @@ -128,7 +128,6 @@ :components ((:file "numeric") #+maxima (:file "symbolic-tensor") - #+nil (:file "matrix" :depends-on ("numeric")))) (:module "matlisp-level-1" @@ -150,7 +149,6 @@ ( (:file "trans" :depends-on ("scal" "copy"))))) - #+nil (:module "matlisp-level-2" :pathname "level-2" diff --git a/src/base/tensor-comprehension.lisp b/src/base/tensor-comprehension.lisp new file mode 100644 index 0000000..a0fdc73 --- /dev/null +++ b/src/base/tensor-comprehension.lisp @@ -0,0 +1,147 @@ +(in-package :matlisp) + +(defparameter *contract-ops* '(sum)) + +;;(defparameter *tgemv* '(contract (ref y i) (+ (* alpha (sum (k) (ref A i k) (ref x k))) (* beta (ref y i))))) + +(defparameter *tclause* '(einstein-sum (ref C i j) (* (ref A i k) (ref B k j)))) + +(defun get-cons (lst sym) + (if (atom lst) nil + (if (eq (car lst) sym) + (list lst) + (append (get-cons (car lst) sym) (get-cons (cdr lst) sym))))) + +(defun get-repeats (lst) + (do ((tmp lst (cdr tmp)) + (ret nil (if (and (not (member (car tmp) ret)) (member (car tmp) (cdr tmp))) + (cons (car tmp) ret) + ret))) + ((null tmp) ret))) + +(defun gensym-list (n) + (loop :repeat n :collect (gensym))) + +#+nil +(defun loop-gen (idx ret einx) + (if (null idx) code + (destructuring-bind (var repeat) (car idx) + `(loop :for ,var :of-type index-type :from ,start :below ,end + :do ,(loop-gen (cdr idx) code))))) + +(tensor-args (get-cons (cddr clause) 'ref)) + (code-idx (get-repeats (apply #'append (mapcar #'cddr tensor-args)))) + (arg-idx (let ((ret nil)) + (mapcar #'(lambda (x) (if (symbolp x) (setf ret (setadd ret x)))) (cddr arg)) + ret)) + (idxs (append arg-idx code-idx)) + (dims (apply #'append (mapcar #'(lambda (x) (loop :for idx :in (cddr x) + :counting t :into i + :when (member idx idxs) + :collect `(,idx (aref (dimensions ,(cadr x)) ,(1- i))))) tensor-args))) + + (osyms (zipsym (mapcar #'(lambda (x) `(head ,(car x))) tsyms))) + (stosyms (zipsym (mapcar #'(lambda (x) `(store ,(car x))) tsyms))) + (stdsyms (zipsym (mapcar #'(lambda (x) `(strides ,(car x))) tsyms))) + (dimsyms (zipsym (mapcar #'(lambda (x) `(dimensions ,(car x))) tsyms)))) + + +(defun mapcons (func lst keys) + (cond + ((atom lst) lst) + ((member (car lst) keys) + (funcall func lst)) + (t + (mapcar #'(lambda (x) (mapcons func x keys)) lst)))) + +(mapcons #'(lambda (x) `(aref (store ,(cadr x)) ,@(cddr x))) + *tclause* '(ref)) + + + (loopgen (idxs cclause place &optional (start? t)) + `(loop + :with ... :of-type index-type := ... + :with ... :of-type index-type := ... + :for (car idxs) :of-type index-type :from 0 :below + + )) + + +(defun loop-generator (type clause &optional (testp t)) + (let* ((ten-syms (mapcar #'(lambda (x) + (let* ((sym (second x)) + (gsym (gensym (symbol-name sym)))) + `((,gsym ,sym) + (,(gensym (string+ "head-" (symbol-name sym))) (head ,gsym)) + (,(gensym (string+ "store-" (symbol-name sym))) (store ,gsym)) + (,(gensym (string+ "strides-" (symbol-name sym))) (strides ,gsym)) + (,(gensym (string+ "dimensions-" (symbol-name sym))) (dimensions ,gsym))))) + (get-cons (cdr clause) 'ref))) + (offsets nil) + (ranges nil)) + (labels ((get-plst (x) + (find x ten-syms :key #'cadar :test #'eql)) + (get-offset (x) + (let ((ofst (find x offsets :key #'cadr :test #'equal))) + (if ofst + (car ofst) + (let ((ofsym (gensym (string+ "offset-" (symbol-name (car x)))))) + (push (list ofsym x) offsets) + ofsym)))) + (testgen () + (let ((dims (apply #'append (mapcar #'(lambda (x) (loop :for ele :in (cdr (cadr x)) + :counting t :into i + :collect (let ((plst (get-plst (car (cadr x))))) + `(,ele (aref ,(car (elt plst 4)) ,(1- i)))))) offsets)))) + (loop :for ele :in dims + :do (let ((cdim (find (car ele) ranges :key #'car :test #'eql))) + (if cdim + (rplacd (last cdim) (cdr ele)) + (push ele ranges)))) + (when testp + `((assert (and ,@(mapcar #'(lambda (x) `(= ,@(cdr x))) ranges)) nil "error: arguments are not of appropriate sizes."))))) + (loopgen (idxs place clause &optional (startp t)) + (let ((cidx (caar idxs))) + `((let*-typed (,@(remove-if #'null + (mapcar #'(lambda (x) + (if (or (member cidx (cdr (cadr x))) startp) + (let ((offset (gensym (string+ "of-" (symbol-name cidx) "-" (symbol-name (car (cadr x))))))) + `(:with ,offset :of-type index-type := ... + :for ,(car x) :of-type index-type := ,(if startp + (let ((plst (get-plst (car (cadr x))))) + (car (elt plst 1))) + (car x)) + :then (the index-type (+ ,offset ,(car x)))) + nil)) + offsets))) + + (loop + :for ,cidx :of-type index-type :from 0 :below ,(cadr (car idxs)) + ,@(apply #'append (remove-if #'null (mapcar #'(lambda (x) + (if (or (member cidx (cdr (cadr x))) startp) + (let ((offset (gensym (string+ "of-" (symbol-name cidx) "-" (symbol-name (car (cadr x))))))) + `(:with ,offset :of-type index-type := ... + :for ,(car x) :of-type index-type := ,(if startp + (let ((plst (get-plst (car (cadr x))))) + (car (elt plst 1))) + (car x)) + :then (the index-type (+ ,offset ,(car x)))) + nil)) + offsets))) + ))))) + (let* ((cclause (mapcons #'(lambda (x) + (let* ((plst (get-plst (cadr x))) + (ofset-sym (get-offset (cdr x)))) + `(t/store-ref ,type ,(caaddr plst) ,ofset-sym))) + clause '(ref)))) + `(let (,@(mapcar #'car ten-syms)) + (declare (type ,type ,@(mapcar #'caar ten-syms))) + (let (,@(apply #'append (mapcar #'cdr ten-syms))) + (declare (type index-type ,@(mapcar #'caadr ten-syms)) + (type ,(store-type type) ,@(mapcar #'caaddr ten-syms)) + (type index-store-vector ,@(mapcar #'car (apply #'append (mapcar #'cdddr ten-syms))))) + ,@(testgen) + ,@(loopgen ranges (cadr cclause) (caddr cclause) t))))))) + + +(loop-generator 'real-tensor *tclause*) diff --git a/src/classes/matrix.lisp b/src/classes/matrix.lisp index 9544477..81c4034 100644 --- a/src/classes/matrix.lisp +++ b/src/classes/matrix.lisp @@ -47,7 +47,7 @@ (or (row-matrix-p matrix) (col-matrix-p matrix))) (definline square-matrix-p (matrix) - (and (square-p matrix) (matrix-p matrix))) + (and (tensor-matrixp matrix) (tensor-squarep matrix))) ;; ;; ;; (defgeneric fill-matrix (matrix fill-element) diff --git a/src/ffi/f77-ffi.lisp b/src/ffi/f77-ffi.lisp index 3fad009..e3a9843 100644 --- a/src/ffi/f77-ffi.lisp +++ b/src/ffi/f77-ffi.lisp @@ -11,341 +11,342 @@ (in-package #:matlisp-ffi) (eval-when (:compile-toplevel :load-toplevel :execute) - (definline %f77.string-p (type) - " + +(definline %f77.string-p (type) + " Checks if the given type is a string." - (eq type :string)) + (eq type :string)) - (definline %f77.array-p (type) - " +(definline %f77.array-p (type) + " Checks if the given type is an array." - (and (listp type) (eq (car type) '*))) + (and (listp type) (eq (car type) '*))) - (definline %f77.cast-as-array-p (type) - " +(definline %f77.cast-as-array-p (type) + " Checks if the given type is - or has to be passed as - an array." - (or (when (listp type) - (eq (car type) '*)) - (eq type :complex-single-float) - (eq type :complex-double-float))) - - ;; Check if the given type is a callback. - (definline %f77.callback-type-p (type) - " + (or (when (listp type) + (eq (car type) '*)) + (eq type :complex-single-float) + (eq type :complex-double-float))) + +;; Check if the given type is a callback. +(definline %f77.callback-type-p (type) + " Checks if the given type is a callback" - (and (listp type) (eq (first type) :callback))) - - ;; Get the equivalent CFFI type. - ;; If the type is an array, get the type of the array element type. - (defun %f77.cffi-type (type) - "Convert the given matlisp-ffi type into one understood by CFFI." - (cond - ((and (listp type) (eq (first type) '*)) - `(:pointer ,(%f77.cffi-type (second type)))) - ((%f77.callback-type-p type) - `(:pointer ,(%f77.cffi-type :callback))) - ((eq type :complex-single-float) - `(:pointer ,(%f77.cffi-type :single-float))) - ((eq type :complex-double-float) - `(:pointer ,(%f77.cffi-type :double-float))) - (t (case type - (:void :void) - (:integer :int32) - (:character :char) - (:long :int64) - (:single-float :float) - (:double-float :double) - (:string :string) - ;; Pass a pointer to the function. - (:callback :void) - (t (error 'unknown-token :token type - :message "Don't know the given Fortran type.")))))) - - (defun %f77.get-return-type (type) - " + (and (listp type) (eq (first type) :callback))) + +;; Get the equivalent CFFI type. +;; If the type is an array, get the type of the array element type. +(defun %f77.cffi-type (type) + "Convert the given matlisp-ffi type into one understood by CFFI." + (cond + ((and (listp type) (eq (first type) '*)) + `(:pointer ,(%f77.cffi-type (second type)))) + ((%f77.callback-type-p type) + `(:pointer ,(%f77.cffi-type :callback))) + ((eq type :complex-single-float) + `(:pointer ,(%f77.cffi-type :single-float))) + ((eq type :complex-double-float) + `(:pointer ,(%f77.cffi-type :double-float))) + (t (case type + (:void :void) + (:integer :int32) + (:character :char) + (:long :int64) + (:single-float :float) + (:double-float :double) + (:string :string) + ;; Pass a pointer to the function. + (:callback :void) + (t (error 'unknown-token :token type + :message "Don't know the given Fortran type.")))))) + +(defun %f77.get-return-type (type) + " Return type understood by CFFI. Note that unlike arguments fortran functions return-by-value." - (if (or (%f77.cast-as-array-p type) (%f77.callback-type-p type)) - (error 'invalid-type :given type :expected '(not (or (%f77.cast-as-array-p type) - (%f77.callback-type-p type))) - :message "A Fortran function cannot return the given type.") - (%f77.cffi-type type))) - - (definline %f77.output-p (style) - " + (if (or (%f77.cast-as-array-p type) (%f77.callback-type-p type)) + (error 'invalid-type :given type :expected '(not (or (%f77.cast-as-array-p type) + (%f77.callback-type-p type))) + :message "A Fortran function cannot return the given type.") + (%f77.cffi-type type))) + +(definline %f77.output-p (style) + " Checks if style implies output." - (member style '(:output :input-output :workspace-output))) + (member style '(:output :input-output :workspace-output))) - (definline %f77.input-p (style) - " +(definline %f77.input-p (style) + " Checks if style implies input." - (member style '(:input :input-value :input-reference :workspace))) + (member style '(:input :input-value :input-reference :workspace))) - (defun %f77.get-read-in-type (type &optional (style :input)) - " +(defun %f77.get-read-in-type (type &optional (style :input)) + " Get the input type to be passed to CFFI." - (assert (member style +ffi-styles+) nil 'unknown-token :token style - :message "Don't know how to handle style.") - (cond - ;; Can't do much else if type is an array/complex or input is passed-by-value. - ((or (%f77.callback-type-p type) - (%f77.cast-as-array-p type) - (eq style :input-value)) - (%f77.cffi-type type)) - ;; else pass-by-reference - (t - `(:pointer ,(%f77.cffi-type type))))) - - (defun %f77.parse-fortran-parameters (body) - " + (assert (member style +ffi-styles+) nil 'unknown-token :token style + :message "Don't know how to handle style.") + (cond + ;; Can't do much else if type is an array/complex or input is passed-by-value. + ((or (%f77.callback-type-p type) + (%f77.cast-as-array-p type) + (eq style :input-value)) + (%f77.cffi-type type)) + ;; else pass-by-reference + (t + `(:pointer ,(%f77.cffi-type type))))) + +(defun %f77.parse-fortran-parameters (body) + " Parse fortran parameters and convert parameters to native C90 types (and add additional function parameters)." - (multiple-value-bind (doc pars) - (parse-doc-&-parameters body) - (declare (ignore doc)) - - (let* ((aux-pars nil) - (new-pars - (mapcar #'(lambda (decl) - (destructuring-bind (name type &optional (style :input-reference)) decl - (case type - (:string - ;; String lengths are appended to the function arguments, - ;; passed by value. - (nconsc aux-pars `((,(scat "LEN-" name) ,(%f77.cffi-type :integer)))) - `(,name ,(%f77.cffi-type :string))) - (t - `(,name ,(%f77.get-read-in-type type style)))))) - pars))) - `( ;; don't want documentation for direct interface, not useful - ;; ,@doc - ,@new-pars ,@aux-pars)))) - - ;; Create a form specifying a simple Lisp function that calls the - ;; underlying Fortran routine of the same name. - (defun %f77.def-fortran-interface (name return-type body hidden-var-name) - (multiple-value-bind (doc pars) - (parse-doc-&-parameters body) - (let ((ffi-fn (make-fortran-ffi-name name)) - (return-vars nil) - (array-vars nil) - (ref-vars nil) - (callback-code nil) - ;; - (defun-args nil) - (defun-keyword-args nil) - ;; - (aux-args nil) + (multiple-value-bind (doc pars) + (parse-doc-&-parameters body) + (declare (ignore doc)) + + (let* ((aux-pars nil) + (new-pars + (mapcar #'(lambda (decl) + (destructuring-bind (name type &optional (style :input-reference)) decl + (case type + (:string + ;; String lengths are appended to the function arguments, + ;; passed by value. + (nconsc aux-pars `((,(scat "LEN-" name) ,(%f77.cffi-type :integer)))) + `(,name ,(%f77.cffi-type :string))) + (t + `(,name ,(%f77.get-read-in-type type style)))))) + pars))) + `( ;; don't want documentation for direct interface, not useful + ;; ,@doc + ,@new-pars ,@aux-pars)))) + +;; Create a form specifying a simple Lisp function that calls the +;; underlying Fortran routine of the same name. +(defun %f77.def-fortran-interface (name return-type body hidden-var-name) + (multiple-value-bind (doc pars) + (parse-doc-&-parameters body) + (let ((ffi-fn (make-fortran-ffi-name name)) + (return-vars nil) + (array-vars nil) + (ref-vars nil) + (callback-code nil) + ;; + (defun-args nil) + (defun-keyword-args nil) + ;; + (aux-args nil) + ;; + (ffi-args nil) + (aux-ffi-args nil) + (callback-args nil)) + (dolist (decl pars) + (destructuring-bind (var type &optional style) decl + (let ((ffi-var nil) + (aux-var nil)) + (cond + ;; Callbacks are tricky. + ((%f77.callback-type-p type) + (let* ((callback-name (second type)) + (field-gvar (intern (string+ "*" (symbol-name (gensym (symbol-name var))) "*"))) + (c-callback-code (%f77.def-fortran-callback field-gvar callback-name (third type) (cdddr type)))) + (nconsc callback-code `((defvar ,field-gvar nil) ,@c-callback-code)) + (nconsc callback-args `((,field-gvar ,var))) + (setq ffi-var `(cffi:callback ,callback-name)))) + ;; Can't really enforce "style" when given an array. + ;; Complex numbers do not latch onto this case, they + ;; are passed by value. + ((%f77.array-p type) + (setq ffi-var (scat "ADDR-" var)) + (nconsc array-vars `((,ffi-var ,var))) + ;; + (when-let (arg (getf type :inc)) + (nconsc defun-keyword-args + `((,arg 0))) + (nconc (car (last array-vars)) `(:inc-type ,(cadr type) :inc ,arg)))) + ;; Strings + ((%f77.string-p type) + (setq ffi-var var) + (setq aux-var (scat "LEN-" var)) + (nconsc aux-args `((,aux-var (length (the string ,var)))))) + ;; Pass-by-value variables + ((eq style :input-value) + (setq ffi-var var)) + ;; Pass-by-reference variables + (t + (cond + ;; Makes more sense to copy complex numbers into + ;; arrays, rather than twiddling around with lisp + ;; memory internals. + ((member type '(:complex-single-float :complex-double-float)) + (setq ffi-var (scat "ADDR-REAL-CAST-" var)) + (nconsc ref-vars + `((,ffi-var ,(second (%f77.cffi-type type)) :count 2 :initial-contents (list (realpart ,var) (imagpart ,var)))))) + (t + (setq ffi-var (scat "REF-" var)) + (nconsc ref-vars + `((,ffi-var ,(%f77.cffi-type type) :initial-element ,@(if (eq type :character) `((char-code ,var)) `(,var) )))))))) + ;; Output variables + (when (and (%f77.output-p style) (not (eq type :string))) + (nconsc return-vars + `((,ffi-var ,var ,type)))) + ;; Arguments for the lisp wrapper + (unless (eq var hidden-var-name) + (nconsc defun-args + `(,var))) + ;; Arguments for the FFI function + (nconsc ffi-args + `(,ffi-var)) + ;; Auxillary arguments for FFI + (unless (null aux-var) + (nconsc aux-ffi-args + `(,aux-var)))))) + ;;Complex returns through hidden variable. + (unless (null hidden-var-name) + (nconsc aux-args `((,hidden-var-name ,(ecase (second (first pars)) + (:complex-single-float #c(0e0 0e0)) + (:complex-double-float #c(0d0 0d0))))))) + ;;Keyword argument list + (unless (null defun-keyword-args) + (setq defun-keyword-args (cons '&optional defun-keyword-args))) + ;;Return the function definition + (let ((retvar (gensym))) + `( + ;;Declare callbacks + ,@callback-code + ,(recursive-append + `(defun ,name ,(append defun-args defun-keyword-args) + ,@doc) ;; - (ffi-args nil) - (aux-ffi-args nil) - (callback-args nil)) - (dolist (decl pars) - (destructuring-bind (var type &optional style) decl - (let ((ffi-var nil) - (aux-var nil)) - (cond - ;; Callbacks are tricky. - ((%f77.callback-type-p type) - (let* ((callback-name (second type)) - (field-gvar (intern (string+ "*" (symbol-name (gensym (symbol-name var))) "*"))) - (c-callback-code (%f77.def-fortran-callback field-gvar callback-name (third type) (cdddr type)))) - (nconsc callback-code `((defvar ,field-gvar nil) ,@c-callback-code)) - (nconsc callback-args `((,field-gvar ,var))) - (setq ffi-var `(cffi:callback ,callback-name)))) - ;; Can't really enforce "style" when given an array. - ;; Complex numbers do not latch onto this case, they - ;; are passed by value. - ((%f77.array-p type) - (setq ffi-var (scat "ADDR-" var)) - (nconsc array-vars `((,ffi-var ,var))) - ;; - (when-let (arg (getf type :inc)) - (nconsc defun-keyword-args - `((,arg 0))) - (nconc (car (last array-vars)) `(:inc-type ,(cadr type) :inc ,arg)))) - ;; Strings - ((%f77.string-p type) - (setq ffi-var var) - (setq aux-var (scat "LEN-" var)) - (nconsc aux-args `((,aux-var (length (the string ,var)))))) - ;; Pass-by-value variables - ((eq style :input-value) - (setq ffi-var var)) - ;; Pass-by-reference variables - (t - (cond - ;; Makes more sense to copy complex numbers into - ;; arrays, rather than twiddling around with lisp - ;; memory internals. - ((member type '(:complex-single-float :complex-double-float)) - (setq ffi-var (scat "ADDR-REAL-CAST-" var)) - (nconsc ref-vars - `((,ffi-var ,(second (%f77.cffi-type type)) :count 2 :initial-contents (list (realpart ,var) (imagpart ,var)))))) - (t - (setq ffi-var (scat "REF-" var)) - (nconsc ref-vars - `((,ffi-var ,(%f77.cffi-type type) :initial-element ,var))))))) - ;; Output variables - (when (and (%f77.output-p style) (not (eq type :string))) - (nconsc return-vars - `((,ffi-var ,var ,type)))) - ;; Arguments for the lisp wrapper - (unless (eq var hidden-var-name) - (nconsc defun-args - `(,var))) - ;; Arguments for the FFI function - (nconsc ffi-args - `(,ffi-var)) - ;; Auxillary arguments for FFI - (unless (null aux-var) - (nconsc aux-ffi-args - `(,aux-var)))))) - ;;Complex returns through hidden variable. - (unless (null hidden-var-name) - (nconsc aux-args `((,hidden-var-name ,(ecase (second (first pars)) - (:complex-single-float #c(0e0 0e0)) - (:complex-double-float #c(0d0 0d0))))))) - ;;Keyword argument list - (unless (null defun-keyword-args) - (setq defun-keyword-args (cons '&optional defun-keyword-args))) - ;;Return the function definition - (let ((retvar (gensym))) - `( - ;;Declare callbacks - ,@callback-code - ,(recursive-append - `(defun ,name ,(append defun-args defun-keyword-args) - ,@doc) - ;; - (unless (null aux-args) - `(let (,@aux-args))) - ;;Don't use with-foreign.. if ref-vars is nil - (unless (null ref-vars) - `(with-foreign-objects-stacked (,@ref-vars))) - ;;Don't use with-vector-dat.. if array-vars is nil - (unless (null array-vars) - `(with-vector-data-addresses (,@array-vars))) - ;;Point the the dummy global variables to the proper functions - (unless (null callback-args) - `(let (,@callback-args))) - ;;Call the foreign-function - `(let ((,retvar (,ffi-fn ,@ffi-args ,@aux-ffi-args))) - ;;Ignore return if type is :void - ,@(when (eq return-type :void) - `((declare (ignore ,retvar)))) - ;; Copy values in reference pointers back to local - ;; variables. Lisp has local scope; its safe to - ;; modify variables in parameter lists. - ,@(mapcar #'(lambda (decl) - (destructuring-bind (ffi-var var type) decl - (if (member type '(:complex-single-float :complex-double-float)) - `(setq ,var (complex (cffi:mem-aref ,ffi-var ,(second (%f77.cffi-type type)) 0) - (cffi:mem-aref ,ffi-var ,(second (%f77.cffi-type type)) 1))) - `(setq ,var (cffi:mem-aref ,ffi-var ,(%f77.cffi-type type)))))) - (remove-if-not #'(lambda (x) - (member (first x) ref-vars :key #'car)) - return-vars)) - (values - ,@(unless (eq return-type :void) - `(,retvar)) - ,@(mapcar #'second return-vars))))))))) - - ;;TODO: Outputs are messed up inside the callback - (defun %f77.def-fortran-callback (func callback-name return-type parm) - (let* ((hack-return-type `,return-type) - (hack-parm `(,@parm)) - (hidden-var-name nil)) - ;; - (when (member hack-return-type '(:complex-single-float :complex-double-float)) - (setq hidden-var-name (gensym "HIDDEN-COMPLEX-RETURN-")) - (setq hack-parm `((,hidden-var-name ,hack-return-type :output) - ,@parm)) - (setq hack-return-type :void)) - ;; - (let* ((new-pars nil) - (aux-pars nil) - (func-pars nil) - (array-vars nil) - (return-vars nil) - (ref-vars nil)) - (dolist (decl hack-parm) - (destructuring-bind (var type &optional (style :input)) decl - (let ((ffi-var nil) - (func-var nil)) - (cond - ;; Callbacks are tricky. - ((%f77.callback-type-p type) - (setq ffi-var var) - (setq func-var var)) - ;; - ((%f77.array-p type) - (setq ffi-var (scat "ADDR-" var)) - (setq func-var var) - (nconsc array-vars `((,func-var (make-foreign-vector :pointer ,ffi-var :type ,(second (%f77.cffi-type type)) - :size ,(if-let (size (getf type :size)) - size - 1)))))) - ;; - ((%f77.string-p type) - (setq ffi-var var) - (setq func-var var) - (nconsc aux-pars - `((,(scat "LEN-" var) ,(%f77.cffi-type :integer))))) - ;; - ((eq style :input-value) - (setq ffi-var var) - (setq func-var var)) - ;; Pass-by-reference variables - (t - (cond - ((member type '(:complex-single-float :complex-double-float)) - (setq ffi-var (scat "ADDR-REAL-CAST-" var)) - (setq func-var var) - (nconsc ref-vars - `((,func-var (complex (cffi:mem-aref ,ffi-var ,(second (%f77.cffi-type type)) 0) - (cffi:mem-aref ,ffi-var ,(second (%f77.cffi-type type)) 1)))))) - (t - (setq ffi-var (scat "REF-" var)) - (setq func-var var) - (nconsc ref-vars - `((,func-var (cffi:mem-aref ,ffi-var ,(%f77.cffi-type type))))))))) - ;; - (nconsc new-pars `((,ffi-var ,(%f77.get-read-in-type type style)))) - (nconsc func-pars `(,func-var)) - (when (and (%f77.output-p style) (not (eq type :string))) - (nconsc return-vars - `((,func-var ,ffi-var ,type))))))) - - (let ((retvar (gensym))) - `( - ,(recursive-append - `(cffi:defcallback ,callback-name ,(%f77.get-return-type hack-return-type) - (,@new-pars ,@aux-pars)) + (unless (null aux-args) + `(let (,@aux-args))) + ;;Don't use with-foreign.. if ref-vars is nil + (unless (null ref-vars) + `(with-foreign-objects-stacked (,@ref-vars))) + ;;Don't use with-vector-dat.. if array-vars is nil + (unless (null array-vars) + `(with-vector-data-addresses (,@array-vars))) + ;;Point the the dummy global variables to the proper functions + (unless (null callback-args) + `(let (,@callback-args))) + ;;Call the foreign-function + `(let ((,retvar (,ffi-fn ,@ffi-args ,@aux-ffi-args))) + ;;Ignore return if type is :void + ,@(when (eq return-type :void) + `((declare (ignore ,retvar)))) + ;; Copy values in reference pointers back to local + ;; variables. Lisp has local scope; its safe to + ;; modify variables in parameter lists. + ,@(mapcar #'(lambda (decl) + (destructuring-bind (ffi-var var type) decl + (if (member type '(:complex-single-float :complex-double-float)) + `(setq ,var (complex (cffi:mem-aref ,ffi-var ,(second (%f77.cffi-type type)) 0) + (cffi:mem-aref ,ffi-var ,(second (%f77.cffi-type type)) 1))) + `(setq ,var (cffi:mem-aref ,ffi-var ,(%f77.cffi-type type)))))) + (remove-if-not #'(lambda (x) + (member (first x) ref-vars :key #'car)) + return-vars)) + (values + ,@(unless (eq return-type :void) + `(,retvar)) + ,@(mapcar #'second return-vars))))))))) + +;;TODO: Outputs are messed up inside the callback +(defun %f77.def-fortran-callback (func callback-name return-type parm) + (let* ((hack-return-type `,return-type) + (hack-parm `(,@parm)) + (hidden-var-name nil)) + ;; + (when (member hack-return-type '(:complex-single-float :complex-double-float)) + (setq hidden-var-name (gensym "HIDDEN-COMPLEX-RETURN-")) + (setq hack-parm `((,hidden-var-name ,hack-return-type :output) + ,@parm)) + (setq hack-return-type :void)) + ;; + (let* ((new-pars nil) + (aux-pars nil) + (func-pars nil) + (array-vars nil) + (return-vars nil) + (ref-vars nil)) + (dolist (decl hack-parm) + (destructuring-bind (var type &optional (style :input)) decl + (let ((ffi-var nil) + (func-var nil)) + (cond + ;; Callbacks are tricky. + ((%f77.callback-type-p type) + (setq ffi-var var) + (setq func-var var)) ;; - (when ref-vars - `(let (,@ref-vars))) + ((%f77.array-p type) + (setq ffi-var (scat "ADDR-" var)) + (setq func-var var) + (nconsc array-vars `((,func-var (make-foreign-vector :pointer ,ffi-var :type ,(second (%f77.cffi-type type)) + :size ,(if-let (size (getf type :size)) + size + 1)))))) ;; - (when array-vars - `(let (,@array-vars))) + ((%f77.string-p type) + (setq ffi-var var) + (setq func-var var) + (nconsc aux-pars + `((,(scat "LEN-" var) ,(%f77.cffi-type :integer))))) ;; - `(multiple-value-bind (,retvar ,@(mapcar #'car return-vars)) (funcall ,func ,@func-pars) - (declare (ignore ,@(mapcar #'car return-vars) - ,@(when (eq hack-return-type :void) - `(,retvar)))) - ,@(mapcar #'(lambda (decl) - (destructuring-bind (func-var ffi-var type) decl - (if (member type '(:complex-single-float :complex-double-float)) - `(setf (cffi:mem-aref ,ffi-var ,(second (%f77.cffi-type type)) 0) (realpart ,func-var) - (cffi:mem-aref ,ffi-var ,(second (%f77.cffi-type type)) 1) (imagpart ,func-var)) - `(setf (cffi:mem-aref ,ffi-var ,(%f77.cffi-type type)) ,func-var)))) - (remove-if-not #'(lambda (x) - (member (first x) ref-vars :key #'car)) - return-vars)) - ,(if (eq hack-return-type :void) - nil - retvar)))))))) - ) + ((eq style :input-value) + (setq ffi-var var) + (setq func-var var)) + ;; Pass-by-reference variables + (t + (cond + ((member type '(:complex-single-float :complex-double-float)) + (setq ffi-var (scat "ADDR-REAL-CAST-" var)) + (setq func-var var) + (nconsc ref-vars + `((,func-var (complex (cffi:mem-aref ,ffi-var ,(second (%f77.cffi-type type)) 0) + (cffi:mem-aref ,ffi-var ,(second (%f77.cffi-type type)) 1)))))) + (t + (setq ffi-var (scat "REF-" var)) + (setq func-var var) + (nconsc ref-vars + `((,func-var (cffi:mem-aref ,ffi-var ,(%f77.cffi-type type))))))))) + ;; + (nconsc new-pars `((,ffi-var ,(%f77.get-read-in-type type style)))) + (nconsc func-pars `(,func-var)) + (when (and (%f77.output-p style) (not (eq type :string))) + (nconsc return-vars + `((,func-var ,ffi-var ,type))))))) + + (let ((retvar (gensym))) + `( + ,(recursive-append + `(cffi:defcallback ,callback-name ,(%f77.get-return-type hack-return-type) + (,@new-pars ,@aux-pars)) + ;; + (when ref-vars + `(let (,@ref-vars))) + ;; + (when array-vars + `(let (,@array-vars))) + ;; + `(multiple-value-bind (,retvar ,@(mapcar #'car return-vars)) (funcall ,func ,@func-pars) + (declare (ignore ,@(mapcar #'car return-vars) + ,@(when (eq hack-return-type :void) + `(,retvar)))) + ,@(mapcar #'(lambda (decl) + (destructuring-bind (func-var ffi-var type) decl + (if (member type '(:complex-single-float :complex-double-float)) + `(setf (cffi:mem-aref ,ffi-var ,(second (%f77.cffi-type type)) 0) (realpart ,func-var) + (cffi:mem-aref ,ffi-var ,(second (%f77.cffi-type type)) 1) (imagpart ,func-var)) + `(setf (cffi:mem-aref ,ffi-var ,(%f77.cffi-type type)) ,func-var)))) + (remove-if-not #'(lambda (x) + (member (first x) ref-vars :key #'car)) + return-vars)) + ,(if (eq hack-return-type :void) + nil + retvar)))))))) +) (defmacro def-fortran-routine (name-and-options return-type &rest body) " diff --git a/src/foreign-core/blas.lisp b/src/foreign-core/blas.lisp index 622fa21..d7dd57b 100644 --- a/src/foreign-core/blas.lisp +++ b/src/foreign-core/blas.lisp @@ -695,7 +695,7 @@ " - (trans :string :input) + (trans :character :input) (m :integer ) (n :integer ) (alpha :double-float ) @@ -800,7 +800,7 @@ " - (uplo :string :input) + (uplo :character :input) (n :integer ) (alpha :double-float ) (a (* :double-float) ) @@ -906,9 +906,9 @@ " - (uplo :string :input) - (trans :string :input) - (diag :string :input) + (uplo :character :input) + (trans :character :input) + (diag :character :input) (n :integer ) (a (* :double-float) ) (lda :integer ) @@ -1013,9 +1013,9 @@ " - (uplo :string :input) - (trans :string :input) - (diag :string :input) + (uplo :character :input) + (trans :character :input) + (diag :character :input) (n :integer ) (a (* :double-float) ) (lda :integer ) @@ -1186,7 +1186,7 @@ " - (uplo :string :input) + (uplo :character :input) (n :integer ) (alpha :double-float ) (x (* :double-float) ) @@ -1285,7 +1285,7 @@ " - (uplo :string :input) + (uplo :character :input) (n :integer ) (alpha :double-float ) (x (* :double-float) ) @@ -1419,8 +1419,8 @@ " - (transa :string :input) - (transb :string :input) + (transa :character :input) + (transb :character :input) (m :integer ) (n :integer ) (k :integer ) @@ -1545,8 +1545,8 @@ " - (uplo :string :input) - (trans :string :input) + (uplo :character :input) + (trans :character :input) (n :integer ) (k :integer ) (alpha :double-float ) @@ -1687,8 +1687,8 @@ " - (uplo :string :input) - (trans :string :input) + (uplo :character :input) + (trans :character :input) (n :integer ) (k :integer ) (alpha :double-float ) @@ -1820,10 +1820,10 @@ " - (side :string :input) - (uplo :string :input) - (transa :string :input) - (diag :string :input) + (side :character :input) + (uplo :character :input) + (transa :character :input) + (diag :character :input) (m :integer ) (n :integer ) (alpha :double-float ) @@ -1955,10 +1955,10 @@ " - (side :string :input) - (uplo :string :input) - (transa :string :input) - (diag :string :input) + (side :character :input) + (uplo :character :input) + (transa :character :input) + (diag :character :input) (m :integer ) (n :integer ) (alpha :double-float ) @@ -2101,7 +2101,7 @@ " - (trans :string :input) + (trans :character :input) (m :integer ) (n :integer ) (alpha :complex-double-float ) @@ -2208,7 +2208,7 @@ " - (uplo :string :input) + (uplo :character :input) (n :integer ) (alpha :complex-double-float ) (a (* :complex-double-float) ) @@ -2314,9 +2314,9 @@ " - (uplo :string :input) - (trans :string :input) - (diag :string :input) + (uplo :character :input) + (trans :character :input) + (diag :character :input) (n :integer ) (a (* :complex-double-float) ) (lda :integer ) @@ -2421,9 +2421,9 @@ " - (uplo :string :input) - (trans :string :input) - (diag :string :input) + (uplo :character :input) + (trans :character :input) + (diag :character :input) (n :integer ) (a (* :complex-double-float) ) (lda :integer ) @@ -2692,7 +2692,7 @@ " - (uplo :string :input) + (uplo :character :input) (n :integer ) (alpha :complex-double-float ) (x (* :complex-double-float) ) @@ -2826,8 +2826,8 @@ " - (transa :string :input) - (transb :string :input) + (transa :character :input) + (transb :character :input) (m :integer ) (n :integer ) (k :integer ) @@ -2960,10 +2960,10 @@ " - (side :string :input) - (uplo :string :input) - (transa :string :input) - (diag :string :input) + (side :character :input) + (uplo :character :input) + (transa :character :input) + (diag :character :input) (m :integer ) (n :integer ) (alpha :complex-double-float ) @@ -3094,10 +3094,10 @@ " - (side :string :input) - (uplo :string :input) - (transa :string :input) - (diag :string :input) + (side :character :input) + (uplo :character :input) + (transa :character :input) + (diag :character :input) (m :integer ) (n :integer ) (alpha :complex-double-float ) @@ -3222,8 +3222,8 @@ " - (uplo :string :input) - (trans :string :input) + (uplo :character :input) + (trans :character :input) (n :integer ) (k :integer ) (alpha :double-float ) @@ -3368,8 +3368,8 @@ " - (uplo :string :input) - (trans :string :input) + (uplo :character :input) + (trans :character :input) (n :integer ) (k :integer ) (alpha :complex-double-float ) diff --git a/src/foreign-core/lap... [truncated message content] |
From: Akshay S. <ak...@us...> - 2013-06-26 06:44:38
|
This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "matlisp". The branch, classy has been updated via 95d41cef90f67e4d0b50ca7679ce5b5bffdd7532 (commit) from 8273423d3f82d599972086c6263975bfebe6c3a2 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 95d41cef90f67e4d0b50ca7679ce5b5bffdd7532 Author: Akshay Srinivasan <aks...@gm...> Date: Tue Jun 25 23:44:21 2013 -0700 Migrated scal. diff --git a/configure b/configure index c26fb60..4beb819 100755 --- a/configure +++ b/configure @@ -711,6 +711,10 @@ LDFLAGS CFLAGS CC GREP +AM_BACKSLASH +AM_DEFAULT_VERBOSITY +AM_DEFAULT_V +AM_V am__untar am__tar AMTAR @@ -775,6 +779,7 @@ SHELL' ac_subst_files='' ac_user_opts=' enable_option_checking +enable_silent_rules enable_dependency_tracking enable_cmucl enable_sbcl @@ -1420,6 +1425,8 @@ Optional Features: --disable-option-checking ignore unrecognized --enable/--with options --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no) --enable-FEATURE[=ARG] include FEATURE [ARG=yes] + --enable-silent-rules less verbose build output (undo: "make V=1") + --disable-silent-rules verbose build output (undo: "make V=0") --enable-dependency-tracking do not reject slow dependency extractors --disable-dependency-tracking @@ -2244,7 +2251,7 @@ ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $ ac_compiler_gnu=$ac_cv_c_compiler_gnu -am__api_version='1.12' +am__api_version='1.13' ac_aux_dir= for ac_dir in "$srcdir" "$srcdir/.." "$srcdir/../.."; do @@ -2457,8 +2464,8 @@ if test x"${MISSING+set}" != xset; then esac fi # Use eval to expand $SHELL -if eval "$MISSING --run true"; then - am_missing_run="$MISSING --run " +if eval "$MISSING --is-lightweight"; then + am_missing_run="$MISSING " else am_missing_run= { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: 'missing' script is too old or missing" >&5 @@ -2698,6 +2705,45 @@ else fi rmdir .tst 2>/dev/null +# Check whether --enable-silent-rules was given. +if test "${enable_silent_rules+set}" = set; then : + enableval=$enable_silent_rules; +fi + +case $enable_silent_rules in # ((( + yes) AM_DEFAULT_VERBOSITY=0;; + no) AM_DEFAULT_VERBOSITY=1;; + *) AM_DEFAULT_VERBOSITY=1;; +esac +am_make=${MAKE-make} +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $am_make supports nested variables" >&5 +$as_echo_n "checking whether $am_make supports nested variables... " >&6; } +if ${am_cv_make_support_nested_variables+:} false; then : + $as_echo_n "(cached) " >&6 +else + if $as_echo 'TRUE=$(BAR$(V)) +BAR0=false +BAR1=true +V=1 +am__doit: + @$(TRUE) +.PHONY: am__doit' | $am_make -f - >/dev/null 2>&1; then + am_cv_make_support_nested_variables=yes +else + am_cv_make_support_nested_variables=no +fi +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $am_cv_make_support_nested_variables" >&5 +$as_echo "$am_cv_make_support_nested_variables" >&6; } +if test $am_cv_make_support_nested_variables = yes; then + AM_V='$(V)' + AM_DEFAULT_V='$(AM_DEFAULT_VERBOSITY)' +else + AM_V=$AM_DEFAULT_VERBOSITY + AM_DEFAULT_V=$AM_DEFAULT_VERBOSITY +fi +AM_BACKSLASH='\' + if test "`cd $srcdir && pwd`" != "`pwd`"; then # Use -I$(srcdir) only when $(srcdir) != ., so that make's output # is not polluted with repeated "-I." @@ -2760,6 +2806,10 @@ mkdir_p='$(MKDIR_P)' # in the wild :-( We should find a proper way to deprecate it ... AMTAR='$${TAR-tar}' + +# We'll loop over all known methods to create a tar archive until one works. +_am_tools='gnutar pax cpio none' + am__tar='$${TAR-tar} chof - "$$tardir"' am__untar='$${TAR-tar} xf -' @@ -2768,6 +2818,7 @@ am__tar='$${TAR-tar} chof - "$$tardir"' am__untar='$${TAR-tar} xf -' + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for grep that handles long lines and -e" >&5 $as_echo_n "checking for grep that handles long lines and -e... " >&6; } if ${ac_cv_path_GREP+:} false; then : @@ -8907,6 +8958,10 @@ _lt_linker_boilerplate=`cat conftest.err` $RM -r conftest* +## CAVEAT EMPTOR: +## There is no encapsulation within the following macros, do not change +## the running order or otherwise move them around unless you know exactly +## what you are doing... if test -n "$compiler"; then lt_prog_compiler_no_builtin_flag= @@ -15373,7 +15428,7 @@ int main() EOF $CC $CFLAGS -c conftest.c $F77 $FFLAGS -o a.out conftest.o -L${BLAS_LAPACK_DIR} -lblas -llapack - if a.out; then + if ./a.out; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } F2C=-ff2c @@ -16973,7 +17028,7 @@ $as_echo "$as_me: executing $ac_file commands" >&6;} case $ac_file$ac_mode in "depfiles":C) test x"$AMDEP_TRUE" != x"" || { - # Autoconf 2.62 quotes --file arguments for eval, but not when files + # Older Autoconf quotes --file arguments for eval, but not when files # are listed without --file. Let's play safe and only enable the eval # if we detect the quoting. case $CONFIG_FILES in @@ -17024,7 +17079,7 @@ $as_echo X"$mf" | DEPDIR=`sed -n 's/^DEPDIR = //p' < "$mf"` test -z "$DEPDIR" && continue am__include=`sed -n 's/^am__include = //p' < "$mf"` - test -z "am__include" && continue + test -z "$am__include" && continue am__quote=`sed -n 's/^am__quote = //p' < "$mf"` # Find all dependency output files, they are included files with # $(DEPDIR) in their names. We invoke sed twice because it is the diff --git a/lib-src/matlisp/dediv.f b/lib-src/matlisp/dediv.f index 6b51547..9afc4e8 100644 --- a/lib-src/matlisp/dediv.f +++ b/lib-src/matlisp/dediv.f @@ -1,7 +1,7 @@ subroutine dediv (n,dx,incx,dy,incy) double precision dx(*),dy(*) integer incx,incy,n -* Multiplies the vector X and Y element-wise. +* Divides the vector Y by X element-wise. * integer i,ix,iy * .. @@ -16,7 +16,7 @@ if (incx.lt.0) ix = (-n+1)*incx + 1 if (incy.lt.0) iy = (-n+1)*incy + 1 do 10 i = 1,n - dy(iy) = dx(ix) * dy(iy) + dy(iy) = dy(iy) / dx(ix) ix = ix + incx iy = iy + incy 10 continue @@ -26,7 +26,7 @@ * code for both increments equal to 1 * 20 do 30 i = 1,n - dy(i) = dx(i) / dy(i) + dy(i) = dy(i) / dx(i) 30 continue diff --git a/lib-src/matlisp/descal.f b/lib-src/matlisp/descal.f index 41cfafb..9286393 100644 --- a/lib-src/matlisp/descal.f +++ b/lib-src/matlisp/descal.f @@ -1,7 +1,7 @@ subroutine descal (n,dx,incx,dy,incy) double precision dx(*),dy(*) integer incx,incy,n -* Multiplies the vector X and Y element-wise. +* Multiplies the vector Y by X element-wise. * integer i,ix,iy * .. @@ -16,7 +16,7 @@ if (incx.lt.0) ix = (-n+1)*incx + 1 if (incy.lt.0) iy = (-n+1)*incy + 1 do 10 i = 1,n - dy(iy) = dx(ix) * dy(iy) + dy(iy) = dy(iy) * dx(ix) ix = ix + incx iy = iy + incy 10 continue diff --git a/lib-src/matlisp/zediv.f b/lib-src/matlisp/zediv.f index b0e8b21..bdf3e58 100644 --- a/lib-src/matlisp/zediv.f +++ b/lib-src/matlisp/zediv.f @@ -1,7 +1,7 @@ subroutine zediv (n,dx,incx,dy,incy) - double precision dx(*),dy(*) + double complex dx(*),dy(*) integer incx,incy,n -* Multiplies the vector X and Y element-wise. +* Divides the vector Y by X element-wise. * integer i,ix,iy * .. @@ -16,7 +16,7 @@ if (incx.lt.0) ix = (-n+1)*incx + 1 if (incy.lt.0) iy = (-n+1)*incy + 1 do 10 i = 1,n - dy(iy) = dx(ix) * dy(iy) + dy(iy) = dy(iy) / dx(ix) ix = ix + incx iy = iy + incy 10 continue @@ -26,9 +26,10 @@ * code for both increments equal to 1 * 20 do 30 i = 1,n - dy(i) = dx(i) / dy(i) + dy(i) = dy(i) / dx(i) 30 continue return end + diff --git a/lib-src/matlisp/zescal.f b/lib-src/matlisp/zescal.f index d5beafb..d2a8d34 100644 --- a/lib-src/matlisp/zescal.f +++ b/lib-src/matlisp/zescal.f @@ -1,7 +1,7 @@ subroutine zescal (n,dx,incx,dy,incy) double complex dx(*),dy(*) integer incx,incy,n -* Multiplies the vector X and Y element-wise. +* Multiplies the vector Y by X element-wise. * integer i,ix,iy * .. @@ -16,7 +16,7 @@ if (incx.lt.0) ix = (-n+1)*incx + 1 if (incy.lt.0) iy = (-n+1)*incy + 1 do 10 i = 1,n - dy(iy) = dx(ix) * dy(iy) + dy(iy) = dy(iy) * dx(ix) ix = ix + incx iy = iy + incy 10 continue diff --git a/matlisp.asd b/matlisp.asd index 4962725..c28a1f4 100644 --- a/matlisp.asd +++ b/matlisp.asd @@ -142,12 +142,12 @@ (:file "swap") (:file "axpy" :depends-on ("maker" "copy")) - #+nil - ( + (:file "scal" + :depends-on ("copy" "maker")) (:file "realimag" :depends-on ("copy")) - (:file "scal" - :depends-on ("copy" "tensor-maker" "realimag")) + #+nil + ( (:file "trans" :depends-on ("scal" "copy"))))) diff --git a/src/base/tweakable.lisp b/src/base/tweakable.lisp index 3ad44fc..6f8b0bb 100644 --- a/src/base/tweakable.lisp +++ b/src/base/tweakable.lisp @@ -27,13 +27,13 @@ ") ;;Level 1--------------------------------------------------------;; -(defparameter *real-l1-fcall-lb* 50000 +(defparameter *real-l1-fcall-lb* 5000 "If the size of the array is less than this parameter, the lisp version of axpy is called in order to avoid FFI overheads. The Fortran function is not called if the tensor does not have a consecutive store (see blas-helpers.lisp/consecutive-store-p).") -(defparameter *complex-l1-fcall-lb* 20000 +(defparameter *complex-l1-fcall-lb* 2500 "If the size of the array is less than this parameter, the lisp version of axpy is called in order to avoid FFI overheads. The Fortran function is not called if the tensor does not have diff --git a/src/level-1/axpy.lisp b/src/level-1/axpy.lisp index dea371b..52aae00 100644 --- a/src/level-1/axpy.lisp +++ b/src/level-1/axpy.lisp @@ -37,47 +37,49 @@ (deft/method t/blas-axpy! (sym blas-numeric-tensor) (a x st-x y st-y) (let ((apy? (null x))) (using-gensyms (decl (a x y)) - `(let (,@decl) - (declare (type ,sym ,@(unless apy? `(,x)) ,y) - ,@(when apy? `((ignore ,x)))) - (let ((sto-x ,(if apy? `(t/store-allocator ,sym 1) `(store ,x))) - (st-x ,(if apy? 0 st-x))) - (declare (type ,(store-type sym) sto-x) - (type index-type st-x)) - ,@(when apy? - `((t/store-set real-tensor (t/fid* ,(field-type sym)) sto-x 0))) - (,(macroexpand-1 `(t/blas-axpy-func ,sym)) - (the index-type (size ,y)) - (the ,(field-type sym) ,a) - sto-x st-x - (the ,(store-type sym) (store ,y)) (the index-type ,st-y) - ,(if apy? 0 `(head ,x)) (head ,y)) - ,y))))) + (with-gensyms (sto-x stp-x) + `(let (,@decl) + (declare (type ,sym ,@(unless apy? `(,x)) ,y) + ,@(when apy? `((ignore ,x)))) + (let ((,sto-x ,(if apy? `(t/store-allocator ,sym 1) `(store ,x))) + (,stp-x ,(if apy? 0 st-x))) + (declare (type ,(store-type sym) ,sto-x) + (type index-type ,stp-x)) + ,@(when apy? + `((t/store-set ,sym (t/fid* ,(field-type sym)) ,sto-x 0))) + (,(macroexpand-1 `(t/blas-axpy-func ,sym)) + (the index-type (size ,y)) + (the ,(field-type sym) ,a) + ,sto-x ,stp-x + (the ,(store-type sym) (store ,y)) (the index-type ,st-y) + ,(if apy? 0 `(head ,x)) (head ,y)) + ,y)))))) (deft/generic (t/axpy! #'subtypep) sym (a x y)) (deft/method t/axpy! (sym standard-tensor) (a x y) (let ((apy? (null x))) (using-gensyms (decl (a x y)) - `(let (,@decl) - (declare (type ,sym ,@(unless apy? `(,x)) ,y) - (type ,(field-type sym) ,a) - ,@(when apy? `((ignore ,x)))) - (let (,@(unless apy? `((sto-x (store ,x)))) - (sto-y (store ,y))) - (declare (type ,(store-type sym) ,@(unless apy? `(sto-x)) sto-y)) - (very-quickly - (mod-dotimes (idx (dimensions ,y)) - :with (linear-sums - ,@(unless apy? `((of-x (strides ,x) (head ,x)))) - (of-y (strides ,y) (head ,y))) - :do (t/store-set ,sym (t/f+ ,(field-type sym) - ,@(if apy? - `(,a) - `((t/f* ,(field-type sym) - ,a (t/store-ref ,sym sto-x of-x)))) - (t/store-ref ,sym sto-y of-y)) - sto-y of-y))) - ,y))))) + (with-gensyms (idx sto-x sto-y of-x of-y) + `(let (,@decl) + (declare (type ,sym ,@(unless apy? `(,x)) ,y) + (type ,(field-type sym) ,a) + ,@(when apy? `((ignore ,x)))) + (let (,@(unless apy? `((,sto-x (store ,x)))) + (,sto-y (store ,y))) + (declare (type ,(store-type sym) ,@(unless apy? `(,sto-x)) ,sto-y)) + (very-quickly + (mod-dotimes (,idx (dimensions ,y)) + :with (linear-sums + ,@(unless apy? `((,of-x (strides ,x) (head ,x)))) + (,of-y (strides ,y) (head ,y))) + :do (t/store-set ,sym (t/f+ ,(field-type sym) + ,@(if apy? + `(,a) + `((t/f* ,(field-type sym) + ,a (t/store-ref ,sym ,sto-x ,of-x)))) + (t/store-ref ,sym ,sto-y ,of-y)) + ,sto-y ,of-y))) + ,y)))))) ;;---------------------------------------------------------------;; (defgeneric axpy! (alpha x y) (:documentation diff --git a/src/level-1/copy.lisp b/src/level-1/copy.lisp index 257bd3e..0d71f6d 100644 --- a/src/level-1/copy.lisp +++ b/src/level-1/copy.lisp @@ -37,82 +37,86 @@ (deft/method t/blas-copy! (sym blas-numeric-tensor) (x st-x y st-y) (let ((ncp? (null st-x))) (using-gensyms (decl (x y)) - `(let (,@decl) - (declare (type ,sym ,@(unless ncp? `(,x)) ,y) - ,@(when ncp? `((type ,(field-type sym) ,x)))) - (let ((sto-x ,(if ncp? `(t/store-allocator ,sym 1) `(store ,x))) - (st-x ,(if ncp? 0 st-x))) - (declare (type ,(store-type sym) sto-x) - (type index-type st-x)) - ,@(when ncp? - `((t/store-set real-tensor ,x sto-x 0))) + (with-gensyms (sto-x stp-x) + `(let (,@decl) + (declare (type ,sym ,@(unless ncp? `(,x)) ,y) + ,@(when ncp? `((type ,(field-type sym) ,x)))) + (let ((,sto-x ,(if ncp? `(t/store-allocator ,sym 1) `(store ,x))) + (,stp-x ,(if ncp? 0 st-x))) + (declare (type ,(store-type sym) ,sto-x) + (type index-type ,stp-x)) + ,@(when ncp? + `((t/store-set ,sym ,x ,sto-x 0))) (,(macroexpand-1 `(t/blas-copy-func ,sym)) (the index-type (size ,y)) - (the ,(store-type sym) sto-x) (the index-type st-x) + (the ,(store-type sym) ,sto-x) (the index-type ,stp-x) (the ,(store-type sym) (store ,y)) (the index-type ,st-y) ,(if ncp? 0 `(head ,x)) (head ,y))) - ,y)))) - + ,y))))) + ;; (deft/generic (t/copy! #'(lambda (a b) (strict-compare (list #'subtypep #'subtypep) a b))) (clx cly) (x y)) (deft/method t/copy! ((clx standard-tensor) (cly standard-tensor)) (x y) (using-gensyms (decl (x y)) - `(let* (,@decl - (sto-x (store ,x)) - (sto-y (store ,y))) - (declare (type ,clx ,x) - (type ,cly ,y) - (type ,(store-type clx) sto-x) - (type ,(store-type cly) sto-y)) - (very-quickly - (mod-dotimes (idx (dimensions ,x)) - :with (linear-sums - (of-x (strides ,x) (head ,x)) - (of-y (strides ,y) (head ,y))) - :do (t/store-set ,cly - ,(recursive-append - (unless (eq clx cly) - `(t/strict-coerce (,(field-type clx) ,(field-type cly)) )) - `(t/store-ref ,clx sto-x of-x)) - sto-y of-y))) - ,y))) + (with-gensyms (sto-x sto-y of-x of-y idx) + `(let* (,@decl + (,sto-x (store ,x)) + (,sto-y (store ,y))) + (declare (type ,clx ,x) + (type ,cly ,y) + (type ,(store-type clx) ,sto-x) + (type ,(store-type cly) ,sto-y)) + (very-quickly + (mod-dotimes (,idx (dimensions ,x)) + :with (linear-sums + (,of-x (strides ,x) (head ,x)) + (,of-y (strides ,y) (head ,y))) + :do (t/store-set ,cly + ,(recursive-append + (unless (eq clx cly) + `(t/strict-coerce (,(field-type clx) ,(field-type cly)) )) + `(t/store-ref ,clx ,sto-x ,of-x)) + ,sto-y ,of-y))) + ,y)))) ;;Coercion messes up optimization in SBCL, so we specialize. (deft/method t/copy! ((clx real-numeric-tensor) (cly complex-numeric-tensor)) (x y) (using-gensyms (decl (x y)) - `(let* (,@decl - (sto-x (store ,x)) - (sto-y (store ,y))) - (declare (type ,clx ,x) - (type ,cly ,y) - (type ,(store-type clx) sto-x) - (type ,(store-type cly) sto-y)) - (very-quickly - (mod-dotimes (idx (dimensions ,x)) - :with (linear-sums - (of-x (strides ,x) (head ,x)) - (of-y (strides ,y) (head ,y))) - :do (t/store-set ,cly - (the ,(field-type cly) (complex (t/coerce ,(store-element-type cly) (t/store-ref ,clx sto-x of-x)) (t/fid+ ,(store-element-type cly)))) - sto-y of-y))) - ,y))) + (with-gensyms (sto-x sto-y of-x of-y idx) + `(let* (,@decl + (,sto-x (store ,x)) + (,sto-y (store ,y))) + (declare (type ,clx ,x) + (type ,cly ,y) + (type ,(store-type clx) ,sto-x) + (type ,(store-type cly) ,sto-y)) + (very-quickly + (mod-dotimes (,idx (dimensions ,x)) + :with (linear-sums + (,of-x (strides ,x) (head ,x)) + (,of-y (strides ,y) (head ,y))) + :do (t/store-set ,cly + (the ,(field-type cly) (complex (t/coerce ,(store-element-type cly) (t/store-ref ,clx ,sto-x ,of-x)) (t/fid+ ,(store-element-type cly)))) + ,sto-y ,of-y))) + ,y)))) ;; (deft/method t/copy! ((clx t) (cly standard-tensor)) (x y) (using-gensyms (decl (x y)) - `(let* (,@decl - (sto-y (store ,y)) - (cx (t/coerce ,(field-type cly) ,x))) - (declare (type ,cly ,y) - (type ,(field-type cly) cx) - (type ,(store-type cly) sto-y)) - ;;This should be safe - (very-quickly - (mod-dotimes (idx (dimensions ,y)) - :with (linear-sums - (of-y (strides ,y) (head ,y))) - :do (t/store-set ,cly cx sto-y of-y))) - ,y))) + (with-gensyms (sto-y of-y idx cx) + `(let* (,@decl + (,sto-y (store ,y)) + (,cx (t/coerce ,(field-type cly) ,x))) + (declare (type ,cly ,y) + (type ,(field-type cly) ,cx) + (type ,(store-type cly) ,sto-y)) + ;;This should be safe + (very-quickly + (mod-dotimes (,idx (dimensions ,y)) + :with (linear-sums + (,of-y (strides ,y) (head ,y))) + :do (t/store-set ,cly ,cx ,sto-y ,of-y))) + ,y)))) ;; (defmethod copy! :before ((x standard-tensor) (y standard-tensor)) @@ -133,7 +137,7 @@ (when (subtypep clx 'blas-numeric-tensor) `(if-let (strd (and (call-fortran? x (t/l1-lb ,clx)) (blas-copyablep x y))) (t/blas-copy! ,clx x (first strd) y (second strd)))) - `(very-quickly (t/copy! (,clx ,cly) x y))) + `(t/copy! (,clx ,cly) x y)) y))) ((coerceable? clx cly) (compile-and-eval @@ -154,7 +158,7 @@ (when (subtypep cly 'blas-numeric-tensor) `(if-let (strd (and (call-fortran? y (t/l1-lb ,cly)) (consecutive-storep y))) (t/blas-copy! ,cly x nil y strd))) - `(very-quickly (t/copy! (t ,cly) x y))))) + `(t/copy! (t ,cly) x y)))) (copy! x y))) ;;Generic function defined in src;base;generic-copy.lisp diff --git a/src/level-1/dot.lisp b/src/level-1/dot.lisp index 3aa4a2f..1866473 100644 --- a/src/level-1/dot.lisp +++ b/src/level-1/dot.lisp @@ -48,26 +48,28 @@ (deft/generic (t/dot #'subtypep) sym (x y &optional conjp)) (deft/method t/dot (sym standard-tensor) (x y &optional (conjp t)) (using-gensyms (decl (x y)) - `(let (,@decl) - (declare (type ,sym ,x ,y)) - (let ((sto-x (store ,x)) - (stp-x (aref (the index-store-vector (strides ,x)) 0)) - (of-x (head ,x)) - (sto-y (store ,y)) - (stp-y (aref (the index-store-vector (strides ,y)) 0)) - (of-y (head ,y)) - (dot (t/fid+ ,(field-type sym)))) - (declare (type ,(store-type sym) sto-x sto-y) - (type index-type stp-x stp-y of-x of-y) - (type ,(field-type sym) dot)) - (loop :repeat (aref (the index-store-vector (dimensions ,x)) 0) - :do (setf dot (t/f+ ,(field-type sym) dot - (t/f* ,(field-type sym) - ,(recursive-append (when conjp `(t/fc ,(field-type sym))) `(t/store-ref ,sym sto-x of-x)) - (t/store-ref ,sym sto-y of-y))) - of-x (+ of-x stp-x) - of-y (+ of-y stp-y))) - dot)))) + (with-gensyms (sto-x sto-y of-x of-y stp-x stp-y dot) + `(let (,@decl) + (declare (type ,sym ,x ,y)) + (let ((,sto-x (store ,x)) + (,stp-x (aref (the index-store-vector (strides ,x)) 0)) + (,of-x (head ,x)) + (,sto-y (store ,y)) + (,stp-y (aref (the index-store-vector (strides ,y)) 0)) + (,of-y (head ,y)) + (,dot (t/fid+ ,(field-type sym)))) + (declare (type ,(store-type sym) ,sto-x ,sto-y) + (type index-type ,stp-x ,stp-y ,of-x ,of-y) + (type ,(field-type sym) ,dot)) + (very-quickly + (loop :repeat (aref (the index-store-vector (dimensions ,x)) 0) + :do (setf ,dot (t/f+ ,(field-type sym) ,dot + (t/f* ,(field-type sym) + ,(recursive-append (when conjp `(t/fc ,(field-type sym))) `(t/store-ref ,sym ,sto-x ,of-x)) + (t/store-ref ,sym ,sto-y ,of-y))) + ,of-x (+ ,of-x ,stp-x) + ,of-y (+ ,of-y ,stp-y)))) + ,dot))))) ;;---------------------------------------------------------------;; (defgeneric dot (x y &optional conjugate-p) (:documentation @@ -126,8 +128,8 @@ (t/blas-dot ,clx x y nil)))) `(if conjugate-p ;;Please do your checks before coming here. - (very-quickly (t/dot ,clx x y t)) - (very-quickly (t/dot ,clx x y nil)))))) + (t/dot ,clx x y t) + (t/dot ,clx x y nil))))) (dot x y conjugate-p)) ;;You pay the piper if you like mixing types. ;;This is (or should be) a rare enough to not matter. diff --git a/src/level-1/realimag.lisp b/src/level-1/realimag.lisp index c09d67a..498f93d 100644 --- a/src/level-1/realimag.lisp +++ b/src/level-1/realimag.lisp @@ -43,40 +43,36 @@ " (etypecase tensor (real-tensor tensor) - (complex-tensor (make-instance (case (rank tensor) - (2 'real-matrix) - (1 'real-vector) - (t 'real-tensor)) - :parent-tensor tensor :store (store tensor) :store-size (length (store tensor)) - :dimensions (dimensions tensor) - :strides (map 'index-store-vector #'(lambda (x) (* 2 x)) (strides tensor)) - :head (the index-type (* 2 (head tensor))))) + (complex-tensor (let ((*check-after-initializing?* nil)) + (make-instance 'real-tensor + :parent-tensor tensor :store (store tensor) + :dimensions (dimensions tensor) + :strides (map 'index-store-vector #'(lambda (x) (* 2 x)) (the index-store-vector (strides tensor))) + :head (the index-type (* 2 (head tensor)))))) (number (realpart tensor)))) (definline tensor-imagpart~ (tensor) " Syntax ====== - (tensor-imagpart~ tensor) + (tensor-realpart~ tensor) Purpose ======= - Returns a new tensor object which points to the \"imaginary\" part of TENSOR. + Returns a new tensor object which points to the real part of TENSOR. Store is shared with TENSOR. - If TENSOR is a scalar, returns its imaginary part. + If TENSOR is a scalar, returns its real part. " (etypecase tensor (real-tensor tensor) - (complex-tensor (make-instance (case (rank tensor) - (2 'real-matrix) - (1 'real-vector) - (t 'real-tensor)) - :parent-tensor tensor :store (store tensor) :store-size (length (store tensor)) - :dimensions (dimensions tensor) - :strides (map 'index-store-vector #'(lambda (x) (* 2 x)) (strides tensor)) - :head (the index-type (+ 1 (* 2 (head tensor)))))) - (number (imagpart tensor)))) + (complex-tensor (let ((*check-after-initializing?* nil)) + (make-instance 'real-tensor + :parent-tensor tensor :store (store tensor) + :dimensions (dimensions tensor) + :strides (map 'index-store-vector #'(lambda (x) (* 2 x)) (the index-store-vector (strides tensor))) + :head (the index-type (1+ (* 2 (head tensor))))))) + (number (realpart tensor)))) (definline tensor-realpart (tensor) " diff --git a/src/level-1/scal.lisp b/src/level-1/scal.lisp index 85be999..6a06b36 100644 --- a/src/level-1/scal.lisp +++ b/src/level-1/scal.lisp @@ -27,240 +27,61 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (in-package #:matlisp) -(deft/generic (t/blas-scal-func #'subtypep) sym ()) -(deft/method t/blas-scal-func (sym real-tensor) () - 'descal) +(deft/generic (t/blas-scdi-func #'subtypep) sym (&optional scal?)) -(deft/method t/blas-scal-func (sym complex-tensor) () - 'zescal) -;; -(deft/generic (t/blas-scal! #'subtypep) sym (sz alpha x st-x)) +(deft/method t/blas-scdi-func (sym real-tensor) (&optional (scal? t)) + (if scal? + 'descal + 'dediv)) -(deft/generic (t/blas-axpy! #'subtypep) sym (a x st-x y st-y)) -(deft/method t/blas-axpy! (sym blas-numeric-tensor) (a x st-x y st-y) - (let ((apy? (null x))) - (using-gensyms (decl (a x y)) +(deft/method t/blas-scdi-func (sym complex-tensor) (&optional (scal? t)) + (if scal? + 'zescal + 'zediv)) +;; +(deft/generic (t/blas-scdi! #'subtypep) sym (x st-x y st-y &optional scal?)) +(deft/generic (t/scdi! #'subtypep) sym (x y &key scal? numx?)) + +(deft/method t/blas-scdi! (sym blas-numeric-tensor) (x st-x y st-y &optional (scal? t)) + (let ((numx? (null st-x))) + (using-gensyms (decl (x y)) + (with-gensyms (sto-x stp-x) + `(let (,@decl) + (declare (type ,sym ,@(unless numx? `(,x)) ,y) + ,@(when numx? `((type ,(field-type sym) ,x)))) + (let ((,sto-x ,(if numx? `(t/store-allocator ,sym 1) `(store ,x))) + (,stp-x ,(if numx? 0 st-x))) + (declare (type ,(store-type sym) ,sto-x) + (type index-type ,stp-x)) + ,@(when numx? + `((t/store-set ,sym ,x ,sto-x 0))) + (,(macroexpand-1 `(t/blas-scdi-func ,sym ,scal?)) + (the index-type (size ,y)) + ,sto-x ,stp-x + (the ,(store-type sym) (store ,y)) (the index-type ,st-y) + ,(if numx? 0 `(head ,x)) (head ,y)) + ,y)))))) + +(deft/method t/scdi! (sym standard-tensor) (x y &key (scal? t) (numx? nil)) + (using-gensyms (decl (x y)) + (with-gensyms (sto-x sto-y of-x of-y idx) `(let (,@decl) - (declare (type ,sym ,@(unless apy? `(,x)) ,y) - ,@(when apy? `((ignore ,x)))) - (let ((sto-x ,(if apy? `(t/store-allocator ,sym 1) `(store ,x))) - (st-x ,(if apy? 0 st-x))) - (declare (type ,(store-type sym) sto-x) - (type index-type st-x)) - ,@(when apy? - `((t/store-set real-tensor (t/fid* ,(field-type sym)) sto-x 0))) - (,(macroexpand-1 `(t/blas-axpy-func ,sym)) - (the index-type (size ,y)) - (the ,(field-type sym) ,a) - sto-x st-x - (the ,(store-type sym) (store ,y)) (the index-type ,st-y) - ,(if apy? 0 `(head ,x)) (head ,y)) - ,y))))) - -(deft/method t/blas-scal! (sym blas-numeric-tensor) (sz a x st-x) - (using-gensyms (decl (x)) - `(let (,@decl) - (declare (type ,sym ,x)) - (,(macroexpand-1 `(t/blas-scal-func ,sym)) - (the index-type ,sz) - (the ,(field-type sym) ,a) - (the ,(store-type sym) (store ,x)) (the index-type ,st-x) - (head ,x)) - ,x))) - - - -(defmacro generate-typed-scal! (func (tensor-class fortran-func fortran-lb)) - (let* ((opt (get-tensor-class-optimization-hashtable tensor-class))) - (assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class) - `(progn - (eval-when (:compile-toplevel :load-toplevel :execute) - (let ((opt (get-tensor-class-optimization-hashtable ',tensor-class))) - (assert opt nil 'tensor-cannot-find-optimization :tensor-class ',tensor-class) - (setf (getf opt :scal) ',func - (get-tensor-class-optimization ',tensor-class) opt))) - (defun ,func (from to) - (declare (type ,tensor-class from to)) - ,(let - ((lisp-routine - `(let ((f-sto (store from)) - (t-sto (store to))) - (declare (type ,(linear-array-type (getf opt :store-type)) f-sto t-sto)) - (very-quickly - (mod-dotimes (idx (dimensions from)) - with (linear-sums - (f-of (strides from) (head from)) - (t-of (strides to) (head to))) - do (let*-typed ((val-f (,(getf opt :reader) f-sto f-of) :type ,(getf opt :element-type)) - (val-t (,(getf opt :reader) t-sto t-of) :type ,(getf opt :element-type)) - (mul (,(getf opt :f*) val-f val-t) :type ,(getf opt :element-type))) - (,(getf opt :value-writer) mul t-sto t-of))))))) - (if fortran-func - `(let* ((call-fortran? (> (number-of-elements to) ,fortran-lb)) - (strd-p (when call-fortran? (blas-copyable-p from to)))) - (cond - ((and strd-p call-fortran?) - (,fortran-func (number-of-elements from) - (store from) (first strd-p) - (store to) (second strd-p) - (head from) (head to))) - (t - ,lisp-routine))) - lisp-routine)) - to)))) - -(defmacro generate-typed-num-scal! (func (tensor-class blas-func fortran-lb)) - (let ((opt (get-tensor-class-optimization-hashtable tensor-class))) - (assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class) - `(progn - (eval-when (:compile-toplevel :load-toplevel :execute) - (let ((opt (get-tensor-class-optimization-hashtable ',tensor-class))) - (assert opt nil 'tensor-cannot-find-optimization :tensor-class ',tensor-class) - (setf (getf opt :num-scal) ',func - (get-tensor-class-optimization ',tensor-class) opt))) - (defun ,func (alpha to) - (declare (type ,tensor-class to) - (type ,(getf opt :element-type) alpha)) - ,(let - ((lisp-routine - `(let ((t-sto (store to))) - (declare (type ,(linear-array-type (getf opt :store-type)) t-sto)) - (very-quickly - (mod-dotimes (idx (dimensions to)) - with (linear-sums - (t-of (strides to) (head to))) - do (let ((scal-val (,(getf opt :f*) (,(getf opt :reader) t-sto t-of) alpha))) - (,(getf opt :value-writer) scal-val t-sto t-of))))))) - (if blas-func - `(let* ((call-fortran? (> (number-of-elements to) ,fortran-lb)) - (min-stride (when call-fortran? (consecutive-store-p to)))) - (cond - ((and call-fortran? min-stride) - (,blas-func (number-of-elements to) alpha (store to) min-stride (head to))) - (t - ,lisp-routine))) - lisp-routine)) - to)))) - -(defmacro generate-typed-div! (func (tensor-class fortran-func fortran-lb)) - (let* ((opt (get-tensor-class-optimization-hashtable tensor-class))) - (assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class) - `(progn - (eval-when (:compile-toplevel :load-toplevel :execute) - (let ((opt (get-tensor-class-optimization-hashtable ',tensor-class))) - (assert opt nil 'tensor-cannot-find-optimization :tensor-class ',tensor-class) - (setf (getf opt :div) ',func - (get-tensor-class-optimization ',tensor-class) opt))) - (defun ,func (from to) - (declare (type ,tensor-class from to)) - ,(let - ((lisp-routine - `(let ((f-sto (store from)) - (t-sto (store to))) - (declare (type ,(linear-array-type (getf opt :store-type)) f-sto t-sto)) - (very-quickly - (mod-dotimes (idx (dimensions from)) - with (linear-sums - (f-of (strides from) (head from)) - (t-of (strides to) (head to))) - do (let*-typed ((val-f (,(getf opt :reader) f-sto f-of) :type ,(getf opt :element-type)) - (val-t (,(getf opt :reader) t-sto t-of) :type ,(getf opt :element-type)) - (mul (,(getf opt :f/) val-f val-t) :type ,(getf opt :element-type))) - (,(getf opt :value-writer) mul t-sto t-of))))))) - (if fortran-func - `(let* ((call-fortran? (> (number-of-elements to) ,fortran-lb)) - (strd-p (when call-fortran? (blas-copyable-p from to)))) - (cond - ((and strd-p call-fortran?) - (,fortran-func (number-of-elements from) - (store from) (first strd-p) - (store to) (second strd-p) - (head from) (head to))) - (t - ,lisp-routine))) - lisp-routine)) - to)))) - -(defmacro generate-typed-num-div! (func (tensor-class fortran-func fortran-lb)) - (let ((opt (get-tensor-class-optimization tensor-class))) - (assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class) - `(progn - (eval-when (:compile-toplevel :load-toplevel :execute) - (let ((opt (get-tensor-class-optimization-hashtable ',tensor-class))) - (assert opt nil 'tensor-cannot-find-optimization :tensor-class ',tensor-class) - (setf (getf opt :num-div) ',func - (get-tensor-class-optimization ',tensor-class) opt))) - (defun ,func (alpha to) - (declare (type ,tensor-class to) - (type ,(getf opt :element-type) alpha)) - ,(let - ((lisp-routine - `(let ((t-sto (store to))) - (declare (type ,(linear-array-type (getf opt :store-type)) t-sto)) - (very-quickly - (mod-dotimes (idx (dimensions to)) - with (linear-sums - (t-of (strides to) (head to))) - do (let-typed ((scal-val (,(getf opt :f/) alpha (,(getf opt :reader) t-sto t-of)) :type ,(getf opt :element-type))) - (,(getf opt :value-writer) scal-val t-sto t-of))))))) - (if fortran-func - `(let* ((call-fortran? (> (number-of-elements to) ,fortran-lb)) - (min-stride (when call-fortran? (consecutive-store-p to)))) - (cond - ((and call-fortran? min-stride) - (let ((num-array (,(getf opt :store-allocator) 1))) - (declare (type ,(linear-array-type (getf opt :store-type)) num-array)) - (let-typed ((id (,(getf opt :fid*)) :type ,(getf opt :element-type))) - (,(getf opt :value-writer) id num-array 0)) - (,fortran-func (number-of-elements to) num-array 0 (store to) min-stride (head to)))) - (t - ,lisp-routine))) - lisp-routine)) - to)))) - -;;Real -(generate-typed-num-scal! real-typed-num-scal! - (real-tensor dscal *real-l1-fcall-lb*)) - -(generate-typed-scal! real-typed-scal! - (real-tensor descal *real-l1-fcall-lb*)) - -(generate-typed-div! real-typed-div! - (real-tensor dediv *real-l1-fcall-lb*)) - -(generate-typed-num-div! real-typed-num-div! - (real-tensor dediv *real-l1-fcall-lb*)) - -;;Complex - -(generate-typed-num-scal! complex-typed-num-scal! - (complex-tensor zordscal *complex-l1-fcall-lb*)) - -(generate-typed-scal! complex-typed-scal! - (complex-tensor zescal *complex-l1-fcall-lb*)) - -(generate-typed-div! complex-typed-div! - (complex-tensor zediv *complex-l1-fcall-lb*)) - -(generate-typed-num-div! complex-typed-num-div! - (complex-tensor zediv *complex-l1-fcall-lb*)) - -;;Symbolic -#+maxima -(progn - (generate-typed-num-scal! symbolic-typed-num-scal! - (symbolic-tensor nil 0)) - - (generate-typed-scal! symbolic-typed-scal! - (symbolic-tensor nil 0)) - - (generate-typed-div! symbolic-typed-div! - (symbolic-tensor nil 0)) - - (generate-typed-num-div! symbolic-typed-num-div! - (symbolic-tensor nil 0))) -;;---------------------------------------------------------------;; - + (declare (type ,sym ,@(unless numx? `(,x)) ,y) + ,@(when numx? `((type ,(field-type sym) ,x)))) + (let (,@(unless numx? `((,sto-x (store ,x)))) + (,sto-y (store ,y))) + (declare (type ,(store-type sym) ,@(unless numx? `(,sto-x)) ,sto-y)) + (very-quickly + (mod-dotimes (,idx (dimensions ,y)) + :with (linear-sums + ,@(unless numx? `((,of-x (strides ,x) (head ,x)))) + (,of-y (strides ,y) (head ,y))) + :do (t/store-set ,sym (,(if scal? 't/f* 't/f/) ,(field-type sym) + (t/store-ref ,sym ,sto-y ,of-y) + ,@(if numx? `(,x) `((t/store-ref ,sym ,sto-x ,of-x)))) + ,sto-y ,of-y)))) + ,y)))) +;; (defgeneric scal! (alpha x) (:documentation " @@ -273,59 +94,102 @@ X <- alpha .* X ") (:method :before ((x standard-tensor) (y standard-tensor)) - (assert (lvec-eq (dimensions x) (dimensions y) #'=) nil - 'tensor-dimension-mismatch))) - -(defmethod scal! ((alpha number) (x real-tensor)) - (real-typed-num-scal! (coerce-real alpha) x)) - -(defmethod scal! ((x real-tensor) (y real-tensor)) - (real-typed-scal! x y)) - -(defmethod scal! ((alpha number) (x complex-tensor)) - (complex-typed-num-scal! (coerce-complex alpha) x)) - -(defmethod scal! ((x complex-tensor) (y complex-tensor)) - (complex-typed-scal! x y)) - -(defmethod scal! ((x real-tensor) (y complex-tensor)) - (let ((tmp (tensor-realpart~ y))) - (real-typed-scal! x tmp) - ;;Move view to the imaginary part - (incf (head tmp)) - (real-typed-scal! x tmp))) - -;; + (assert (very-quickly (lvec-eq (the index-store-vector (dimensions x)) (the index-store-vector (dimensions y)) #'=)) nil + 'tensor-dimension-mismatch))) + +(defmethod scal! ((x standard-tensor) (y standard-tensor)) + (let ((clx (class-name (class-of x))) + (cly (class-name (class-of y)))) + (assert (and (member clx *tensor-type-leaves*) + (member cly *tensor-type-leaves*)) + nil 'tensor-abstract-class :tensor-class (list clx cly)) + (cond + ((eq clx cly) + (compile-and-eval + `(defmethod scal! ((x ,clx) (y ,cly)) + ,(recursive-append + (when (subtypep clx 'blas-numeric-tensor) + `(if-let (strd (and (call-fortran? x (t/l1-lb ,clx)) (blas-copyablep x y))) + (t/blas-scdi! ,clx x (first strd) y (second strd) t))) + `(t/scdi! ,clx x y :scal? t :numx? nil)) + y)) + (scal! x y)) + ((coerceable? clx cly) + (scal! (coerce-tensor x cly) y)) + (t + (error "Don't know how to apply scal! to classes ~a, ~a." clx cly))))) + +(defmethod scal! ((x t) (y standard-tensor)) + (let ((cly (class-name (class-of y)))) + (assert (member cly *tensor-type-leaves*) + nil 'tensor-abstract-class :tensor-class cly) + (compile-and-eval + `(defmethod scal! ((x t) (y ,cly)) + (let ((x (t/coerce ,(field-type cly) x))) + (declare (type ,(field-type cly) x)) + ,(recursive-append + (when (subtypep cly 'blas-numeric-tensor) + `(if-let (strd (and (call-fortran? y (t/l1-lb ,cly)) (consecutive-storep y))) + (t/blas-scdi! ,cly x nil y strd t))) + `(t/scdi! ,cly x y :scal? t :numx? t)) + y))) + (scal! x y))) + +;;These should've auto-generated. (defgeneric div! (alpha x) - (:documentation " + (:documentation + " Syntax ====== - (div! alpha x) + (DIV! alpha x) Purpose ======= - X <- alpha ./ X + X <- X ./ alpha + + Yes the calling order is twisted. ") (:method :before ((x standard-tensor) (y standard-tensor)) - (assert (lvec-eq (dimensions x) (dimensions y) #'=) nil - 'tensor-dimension-mismatch))) - -(defmethod div! ((alpha number) (x real-tensor)) - (real-typed-num-div! (coerce-real alpha) x)) - -(defmethod div! ((x real-tensor) (y real-tensor)) - (real-typed-div! x y)) - -(defmethod div! ((alpha number) (x complex-tensor)) - (complex-typed-num-div! (coerce-complex alpha) x)) - -(defmethod div! ((x complex-tensor) (y complex-tensor)) - (complex-typed-div! x y)) - -(defmethod div! ((x real-tensor) (y complex-tensor)) - ;;The alternative is worse! - (let ((tmp (copy! x (apply #'make-complex-tensor (lvec->list (dimensions x)))))) - (complex-typed-div! tmp y))) + (assert (very-quickly (lvec-eq (the index-store-vector (dimensions x)) (the index-store-vector (dimensions y)) #'=)) nil + 'tensor-dimension-mismatch))) + +(defmethod div! ((x standard-tensor) (y standard-tensor)) + (let ((clx (class-name (class-of x))) + (cly (class-name (class-of y)))) + (assert (and (member clx *tensor-type-leaves*) + (member cly *tensor-type-leaves*)) + nil 'tensor-abstract-class :tensor-class (list clx cly)) + (cond + ((eq clx cly) + (compile-and-eval + `(defmethod div! ((x ,clx) (y ,cly)) + ,(recursive-append + (when (subtypep clx 'blas-numeric-tensor) + `(if-let (strd (and (call-fortran? x (t/l1-lb ,clx)) (blas-copyablep x y))) + (t/blas-scdi! ,clx x (first strd) y (second strd) nil))) + `(t/scdi! ,clx x y :scal? nil :numx? nil)) + y)) + (div! x y)) + ((coerceable? clx cly) + (div! (coerce-tensor x cly) y)) + (t + (error "Don't know how to apply div! to classes ~a, ~a." clx cly))))) + +(defmethod div! ((x t) (y standard-tensor)) + (let ((cly (class-name (class-of y)))) + (assert (member cly *tensor-type-leaves*) + nil 'tensor-abstract-class :tensor-class cly) + (compile-and-eval + `(defmethod div! ((x t) (y ,cly)) + (let ((x (t/coerce ,(field-type cly) x))) + (declare (type ,(field-type cly) x)) + ,(recursive-append + (when (subtypep cly 'blas-numeric-tensor) + `(if-let (strd (and (call-fortran? y (t/l1-lb ,cly)) (consecutive-storep y))) + (t/blas-scdi! ,cly x nil y strd nil))) + `(t/scdi! ,cly x y :scal? nil :numx? t)) + y))) + (div! x y))) ;; (defgeneric scal (alpha x) @@ -343,40 +207,13 @@ where alpha is a scalar and X is a tensor. -")) - -(defmethod scal ((alpha number) (x number)) - (* alpha x)) - -(defmethod scal ((x standard-tensor) (alpha number)) - (scal alpha x)) - -(defmethod scal ((alpha number) (x real-tensor)) - (let ((result (if (complexp alpha) - (copy! x (apply #'make-complex-tensor (lvec->list (dimensions x)))) - (copy x)))) - (scal! alpha result))) - -(defmethod scal ((x real-tensor) (y real-tensor)) - (scal! x (copy y))) - -(defmethod scal ((x complex-tensor) (y real-tensor)) - (let ((result (copy! y (apply #'make-complex-tensor (lvec->list (dimensions x)))))) - (scal! x result))) - -(defmethod scal ((alpha number) (x complex-tensor)) - (let ((result (copy x))) - (scal! alpha result))) - -(defmethod scal ((x real-tensor) (y complex-tensor)) - (let ((result (copy y))) - (scal! x result))) - -(defmethod scal ((x complex-tensor) (y complex-tensor)) - (let ((result (copy y))) - (scal! x result))) +") + (:method (alpha x) + (scal! alpha (copy x))) + ;;TODO: There is an issue here when x is not coerceable into the tensor class of alpha + (:method ((alpha standard-tensor) (x t)) + (scal! alpha (copy! x (zeros (dimensions alpha) (class-of alpha)))))) -;; (defgeneric div (x y) (:documentation " Syntax @@ -385,43 +222,12 @@ Purpose ======= - alpha ./ X + X ./ alpha Yes the calling order is twisted. -")) - -(defmethod div ((alpha number) (x number)) - (/ x alpha)) - -(defmethod div ((x standard-tensor) (y number)) - (let ((result (copy x))) - (scal! (/ 1 y) result))) - -(defmethod div ((x (eql nil)) (y standard-tensor)) - (let ((result (copy y))) - (div! 1 result))) - -(defmethod div ((x real-tensor) (y real-tensor)) - (div! x (copy y))) - -(defmethod div ((alpha number) (x real-tensor)) - (let ((result (if (complexp alpha) - (copy! x (apply #'make-complex-tensor (lvec->list (dimensions x)))) - (copy x)))) - (div! alpha result))) - -(defmethod div ((x complex-tensor) (y real-tensor)) - (let ((result (copy! y (apply #'make-complex-tensor (lvec->list (dimensions x)))))) - (div! x result))) - -(defmethod div ((alpha number) (x complex-tensor)) - (let ((result (copy x))) - (div! alpha result))) - -(defmethod div ((x real-tensor) (y complex-tensor)) - (let ((result (copy y))) - (div! x result))) - -(defmethod div ((x complex-tensor) (y complex-tensor)) - (let ((result (copy y))) - (div! x result))) +") + (:method (alpha x) + (div! alpha (copy x))) + ;;TODO: There is an issue here when x is not coerceable into the tensor class of alpha + (:method ((alpha standard-tensor) (x t)) + (div! alpha (copy! x (zeros (dimensions alpha) (class-of alpha)))))) diff --git a/src/level-1/swap.lisp b/src/level-1/swap.lisp index a177a03..2d0245b 100644 --- a/src/level-1/swap.lisp +++ b/src/level-1/swap.lisp @@ -48,22 +48,23 @@ (deft/generic (t/swap! #'subtypep) sym (x y)) (deft/method t/swap! (sym standard-tensor) (x y) (using-gensyms (decl (x y)) - `(let (,@decl - (sto-x (store ,x)) - (sto-y (store ,y))) + (with-gensyms (idx sto-x sto-y of-x of-y y-val) + `(let* (,@decl + (,sto-x (store ,x)) + (,sto-y (store ,y))) (declare (type ,sym ,x ,y) - (type ,(store-type sym) sto-x sto-y)) + (type ,(store-type sym) ,sto-x ,sto-y)) (very-quickly - (mod-dotimes (idx (dimensions ,x)) + (mod-dotimes (,idx (dimensions ,x)) :with (linear-sums - (of-x (strides ,x) (head ,x)) - (of-y (strides ,y) (head ,y))) - :do (let-typed ((y-val (t/store-ref ,sym sto-y of-y) :type ,(field-type sym))) + (,of-x (strides ,x) (head ,x)) + (,of-y (strides ,y) (head ,y))) + :do (let-typed ((,y-val (t/store-ref ,sym ,sto-y ,of-y) :type ,(field-type sym))) (t/store-set ,sym - (t/store-ref ,sym sto-x of-x) sto-y of-y) + (t/store-ref ,sym ,sto-x ,of-x) ,sto-y ,of-y) (t/store-set ,sym - y-val sto-x of-x))) - ,y)))) + ,y-val ,sto-x ,of-x))) + ,y))))) ;;---------------------------------------------------------------;; (defmethod swap! :before ((x standard-tensor) (y standard-tensor)) (assert (very-quickly (lvec-eq (the index-store-vector (dimensions x)) (the index-store-vector (dimensions y)) #'=)) nil diff --git a/src/level-1/trans.lisp b/src/level-1/trans.lisp index 2f7ab5b..b2b8154 100644 --- a/src/level-1/trans.lisp +++ b/src/level-1/trans.lisp @@ -80,11 +80,11 @@ is basically the same as (copy! value (TRANSPOSE~ tensor permutation))" (declare (type standard-tensor A)) - (let ((displaced (make-instance (class-of A) :store (store A) - :store-size (store-size A) - :dimensions (copy-seq (dimensions A)) - :strides (copy-seq (strides A)) - :parent-tensor A))) + (let ((displaced (let ((*check-after-initializing?* nil)) + (make-instance (class-of A) :store (store A) + :dimensions (copy-seq (dimensions A)) + :strides (copy-seq (strides A)) + :parent-tensor A)))) (transpose! displaced permutation))) (definline (setf transpose~) (value A &optional permutation) @@ -140,7 +140,7 @@ (etypecase A (real-tensor A) (complex-tensor - (real-typed-num-scal! -1d0 (tensor-imagpart~ A)) + (scal! -1d0 (tensor-imagpart~ A)) A) (number (conjugate A)))) diff --git a/src/utilities/macros.lisp b/src/utilities/macros.lisp index a0230d0..738ab74 100644 --- a/src/utilities/macros.lisp +++ b/src/utilities/macros.lisp @@ -204,7 +204,7 @@ ,@body)) (defmacro using-gensyms ((decl (&rest syms)) &rest body) - `(let ((,decl (zipsym (list ,@syms)))) + `(let ((,decl (zip ',(mapcar #'(lambda (x) (gensym (symbol-name x))) syms) (list ,@syms)))) (destructuring-bind (,@syms) (mapcar #'car ,decl) ,@body))) ----------------------------------------------------------------------- Summary of changes: configure | 67 ++++++- lib-src/matlisp/dediv.f | 6 +- lib-src/matlisp/descal.f | 4 +- lib-src/matlisp/zediv.f | 9 +- lib-src/matlisp/zescal.f | 4 +- matlisp.asd | 8 +- src/base/tweakable.lisp | 4 +- src/level-1/axpy.lisp | 74 ++++---- src/level-1/copy.lisp | 128 ++++++------ src/level-1/dot.lisp | 46 +++-- src/level-1/realimag.lisp | 36 ++-- src/level-1/scal.lisp | 500 ++++++++++++++------------------------------- src/level-1/swap.lisp | 23 +- src/level-1/trans.lisp | 12 +- src/utilities/macros.lisp | 2 +- 15 files changed, 395 insertions(+), 528 deletions(-) hooks/post-receive -- matlisp |
From: Akshay S. <ak...@us...> - 2013-06-25 09:07:30
|
This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "matlisp". The branch, classy has been updated via 8273423d3f82d599972086c6263975bfebe6c3a2 (commit) via d7210a4b81356e32907afde8bcd13d4cbf97dd00 (commit) via 1407d41f3f3150a905e8cf33e07db5042651f8ae (commit) via 4248b0bfbfb4fda8e99fee6edad8383f2afcf606 (commit) via ecbc68d2926eb4dc1299401beb741e3551a3941d (commit) from 50fcc688d2f72e751722b74e994808ad90f4c1ce (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 8273423d3f82d599972086c6263975bfebe6c3a2 Author: Akshay Srinivasan <aks...@gm...> Date: Tue Jun 25 02:05:01 2013 -0700 Tweaked the templates. Migrated axpy. diff --git a/matlisp.asd b/matlisp.asd index 832ab71..4962725 100644 --- a/matlisp.asd +++ b/matlisp.asd @@ -139,16 +139,15 @@ :depends-on ("maker")) (:file "dot" :depends-on ("maker")) - (:file "swap") + (:file "swap") + (:file "axpy" + :depends-on ("maker" "copy")) #+nil - ( - + ( (:file "realimag" :depends-on ("copy")) (:file "scal" :depends-on ("copy" "tensor-maker" "realimag")) - (:file "axpy" - :depends-on ("copy" "scal")) (:file "trans" :depends-on ("scal" "copy"))))) diff --git a/src/base/print.lisp b/src/base/print.lisp index 0d76da4..d058298 100644 --- a/src/base/print.lisp +++ b/src/base/print.lisp @@ -105,7 +105,7 @@ of a matrix (default 0) (defmethod print-object ((tensor standard-tensor) stream) (print-unreadable-object (tensor stream :type t) - (if (slot-boundp tensor 'parent-tensor) + (if (slot-value tensor 'parent-tensor) (format stream "~A~,4T:DISPLACED~%" (dimensions tensor)) (format stream "~A~%" (dimensions tensor))) (print-tensor tensor stream))) diff --git a/src/base/standard-tensor.lisp b/src/base/standard-tensor.lisp index 0544757..fb762a3 100644 --- a/src/base/standard-tensor.lisp +++ b/src/base/standard-tensor.lisp @@ -48,7 +48,7 @@ ((dimensions :reader dimensions :initarg :dimensions :type index-store-vector :documentation "Dimensions of the vector spaces in which the tensor's arguments reside.") ;; - (parent-tensor :reader parent-tensor :initarg :parent-tensor :type standard-tensor + (parent-tensor :reader parent-tensor :initform nil :initarg :parent-tensor :type standard-tensor :documentation "If the tensor is a view of another tensor, then this slot is bound.") ;; (head :initarg :head :initform 0 :reader head :type index-type @@ -81,6 +81,11 @@ tensor, for example #.(make-tensors ...)" (make-load-form-saving-slots tensor :environment env)) +;; +(definline coerce-tensor (x cly) + (declare (type standard-tensor x)) + (copy! x (zeros (the index-store-vector (dimensions x)) cly))) + ;;These should ideally be memoised (or not) (definline rank (tensor) (declare (type standard-tensor tensor)) @@ -417,9 +422,10 @@ (incf nhd (the index-type (* start (aref stds i))))))) :finally (return (if (= nrank 0) (store-ref tensor nhd) - (make-instance (class-of tensor) - :head nhd - :dimensions (prune-index-vector! ndims nrank) - :strides (prune-index-vector! nstds nrank) - :store (store tensor) - :parent-tensor tensor))))))) + (let ((*check-after-initializing?* nil)) + (make-instance (class-of tensor) + :head nhd + :dimensions (prune-index-vector! ndims nrank) + :strides (prune-index-vector! nstds nrank) + :store (store tensor) + :parent-tensor tensor)))))))) diff --git a/src/level-1/axpy.lisp b/src/level-1/axpy.lisp index a604af8..dea371b 100644 --- a/src/level-1/axpy.lisp +++ b/src/level-1/axpy.lisp @@ -32,76 +32,53 @@ 'daxpy) (deft/method t/blas-axpy-func (sym complex-tensor) () 'zaxpy) -;; - -(deft/generic (t/blas-axpy! #'subtypep) sym (sz a x st-x y st-y)) -(deft/method t/blas-axpy! (sym blas-numeric-tensor) (sz a x st-x y st-y) - (using-gensyms (decl (x y)) - `(let (,@decl) - (declare (type ,sym ,x ,y)) - (,(macroexpand-1 `(t/blas-axpy-func ,sym)) - (the index-type ,sz) - (the ,(field-type sym) ,a) - (the ,(store-type sym) (store ,x)) (the index-type ,st-x) - (the ,(store-type sym) (store ,y)) (the index-type ,st-y) - (head ,x) (head ,y)) - ,y))) - -(deft/generic (t/blas-apy! #'subtypep) sym (sz a y st-y)) -(deft/method t/blas-apy! (sym blas-numeric-tensor) (sz a y st-y) - (using-gensyms (decl (a y)) - `(let (,@decl) - (declare (type ,sym ,y) - (type ,(field-type sym) ,a)) - (let ((sto-a (t/store-allocator ,sym 1))) - (declare (type ,(store-type sym) sto-a)) - (t/store-set ,sym ,a sto-a 0) +;; +(deft/generic (t/blas-axpy! #'subtypep) sym (a x st-x y st-y)) +(deft/method t/blas-axpy! (sym blas-numeric-tensor) (a x st-x y st-y) + (let ((apy? (null x))) + (using-gensyms (decl (a x y)) + `(let (,@decl) + (declare (type ,sym ,@(unless apy? `(,x)) ,y) + ,@(when apy? `((ignore ,x)))) + (let ((sto-x ,(if apy? `(t/store-allocator ,sym 1) `(store ,x))) + (st-x ,(if apy? 0 st-x))) + (declare (type ,(store-type sym) sto-x) + (type index-type st-x)) + ,@(when apy? + `((t/store-set real-tensor (t/fid* ,(field-type sym)) sto-x 0))) (,(macroexpand-1 `(t/blas-axpy-func ,sym)) - (the index-type ,sz) - (t/fid* ,(field-type sym)) - (the ,(store-type sym) sto-a) 0 + (the index-type (size ,y)) + (the ,(field-type sym) ,a) + sto-x st-x (the ,(store-type sym) (store ,y)) (the index-type ,st-y) - 0 (head ,y))) - ,y))) + ,(if apy? 0 `(head ,x)) (head ,y)) + ,y))))) (deft/generic (t/axpy! #'subtypep) sym (a x y)) (deft/method t/axpy! (sym standard-tensor) (a x y) - (using-gensyms (decl (a x y)) - `(let (,@decl) - (declare (type ,sym ,x ,y) - (type ,(field-type sym) ,a)) - (let ((sto-x (store ,x)) + (let ((apy? (null x))) + (using-gensyms (decl (a x y)) + `(let (,@decl) + (declare (type ,sym ,@(unless apy? `(,x)) ,y) + (type ,(field-type sym) ,a) + ,@(when apy? `((ignore ,x)))) + (let (,@(unless apy? `((sto-x (store ,x)))) (sto-y (store ,y))) - (declare (type ,(store-type sym) sto-x sto-y)) - (mod-dotimes (idx (dimensions ,x)) - :with (linear-sums - (of-x (strides ,x) (head ,x)) - (of-y (strides ,y) (head ,y))) - :do (t/store-set ,sym (t/f+ ,(field-type sym) - (t/f* ,(field-type sym) - ,a (t/store-ref ,sym sto-x of-x)) - (t/store-ref ,sym sto-y of-y)) - sto-y of-y))) - ,y))) - -(deft/generic (t/apy! #'subtypep) sym (a y)) -(deft/method t/apy! (sym standard-tensor) (a y) - (using-gensyms (decl (a y)) - `(let (,@decl) - (declare (type ,sym ,y) - (type ,(field-type sym) ,a)) - (let ((sto-y (store ,y))) - (declare (type ,(store-type sym) sto-y)) - (mod-dotimes (idx (dimensions ,y)) - :with (linear-sums - (of-y (strides ,y) (head ,y))) - :do (t/store-set ,sym (t/f+ ,(field-type sym) - ,a - (t/store-ref ,sym sto-y of-y)) - sto-y of-y))) - ,y))) + (declare (type ,(store-type sym) ,@(unless apy? `(sto-x)) sto-y)) + (very-quickly + (mod-dotimes (idx (dimensions ,y)) + :with (linear-sums + ,@(unless apy? `((of-x (strides ,x) (head ,x)))) + (of-y (strides ,y) (head ,y))) + :do (t/store-set ,sym (t/f+ ,(field-type sym) + ,@(if apy? + `(,a) + `((t/f* ,(field-type sym) + ,a (t/store-ref ,sym sto-x of-x)))) + (t/store-ref ,sym sto-y of-y)) + sto-y of-y))) + ,y))))) ;;---------------------------------------------------------------;; - (defgeneric axpy! (alpha x y) (:documentation " @@ -122,35 +99,47 @@ ") (:method :before ((alpha number) (x standard-tensor) (y standard-tensor)) (assert (lvec-eq (dimensions x) (dimensions y) #'=) nil - 'tensor-dimension-mismatch)) - (:method ((alpha number) (x complex-tensor) (y real-tensor)) - (error 'coercion-error :from 'complex-tensor :to 'real-tensor))) - -(defmethod axpy! ((alpha number) (x (eql nil)) (y real-tensor)) - (real-typed-num-axpy! (coerce-real alpha) y)) - -(defmethod axpy! ((alpha number) (x (eql nil)) (y complex-tensor)) - (complex-typed-num-axpy! (coerce-complex alpha) y)) - -(defmethod axpy! ((alpha number) (x real-tensor) (y real-tensor)) - (real-typed-axpy! (coerce-real alpha) x y)) - -(defmethod axpy! ((alpha number) (x real-tensor) (y complex-tensor)) - ;;Weird, shouldn't SBCL know this already ? - (declare (type complex-tensor y)) - (let ((tmp (tensor-realpart~ y))) - (declare (type real-tensor tmp)) - (etypecase alpha - (cl:real (real-typed-axpy! (coerce-real alpha) x tmp)) - (cl:complex - (real-typed-axpy! (coerce-real (realpart alpha)) x tmp) - ;;Move tensor to the imagpart. - (incf (head tmp)) - (real-typed-axpy! (coerce-real (realpart alpha)) x tmp)))) - y) - -(defmethod axpy! ((alpha number) (x complex-tensor) (y complex-tensor)) - (complex-typed-axpy! (coerce-complex alpha) x y)) + 'tensor-dimension-mismatch))) + +(defmethod axpy! (alpha (x standard-tensor) (y standard-tensor)) + (let ((clx (class-name (class-of x))) + (cly (class-name (class-of y)))) + (assert (and (member clx *tensor-type-leaves*) + (member cly *tensor-type-leaves*)) + nil 'tensor-abstract-class :tensor-class (list clx cly)) + (cond + ((eq clx cly) + (compile-and-eval + `(defmethod axpy! ((alpha t) (x ,clx) (y ,cly)) + (let ((alpha (t/coerce ,(field-type clx) alpha))) + (declare (type ,(field-type clx) alpha)) + ,(recursive-append + (when (subtypep clx 'blas-numeric-tensor) + `(if-let (strd (and (call-fortran? x (t/l1-lb ,clx)) (blas-copyablep x y))) + (t/blas-axpy! ,clx alpha x (first strd) y (second strd)))) + `(t/axpy! ,clx alpha x y)) + y))) + (axpy! alpha x y)) + ((coerceable? clx cly) + (axpy! alpha (coerce-tensor x cly) y)) + (t + (error "Don't know how to apply axpy! to classes ~a, ~a." clx cly))))) + +(defmethod axpy! (alpha (x (eql nil)) (y standard-tensor)) + (let ((cly (class-name (class-of y)))) + (assert (member cly *tensor-type-leaves*) + nil 'tensor-abstract-class :tensor-class cly) + (compile-and-eval + `(defmethod axpy! ((alpha t) (x (eql nil)) (y ,cly)) + (let ((alpha (t/coerce ,(field-type cly) alpha))) + (declare (type ,(field-type cly) alpha)) + ,(recursive-append + (when (subtypep cly 'blas-numeric-tensor) + `(if-let (strd (and (call-fortran? y (t/l1-lb ,cly)) (consecutive-storep y))) + (t/blas-axpy! ,cly alpha nil nil y strd))) + `(t/axpy! ,cly alpha nil y)) + y))) + (axpy! alpha nil y))) ;; (defgeneric axpy (alpha x y) @@ -174,37 +163,5 @@ X,Y must have the same dimensions. ") - (:method :before ((alpha number) (x standard-tensor) (y standard-tensor)) - (unless (lvec-eq (dimensions x) (dimensions y) #'=) - (error 'tensor-dimension-mismatch)))) - -(defmethod axpy ((alpha number) (x real-tensor) (y real-tensor)) - (let ((ret (if (complexp alpha) - (copy! y (apply #'make-complex-tensor (lvec->list (dimensions y)))) - (copy y)))) - (axpy! alpha x ret))) - -(defmethod axpy ((alpha number) (x complex-tensor) (y real-tensor)) - (let ((ret (copy! y (apply #'make-complex-tensor (lvec->list (dimensions y)))))) - (axpy! alpha y ret))) - -(defmethod axpy ((alpha number) (x real-tensor) (y complex-tensor)) - (let ((ret (copy y))) - (axpy! alpha x ret))) - -(defmethod axpy ((alpha number) (x complex-tensor) (y complex-tensor)) - (let ((ret (copy y))) - (axpy! alpha x ret))) - -(defmethod axpy ((alpha number) (x (eql nil)) (y complex-tensor)) - (let ((ret (copy y))) - (axpy! alpha nil ret))) - -(defmethod axpy ((alpha number) (x (eql nil)) (y real-tensor)) - (let ((ret (if (complexp alpha) - (copy! y (apply #'make-complex-tensor (lvec->list (dimensions y)))) - (copy y)))) - (axpy! alpha nil ret))) - -(defmethod axpy ((alpha number) (x standard-tensor) (y (eql nil))) - (scal alpha x)) + (:method (alpha x (y standard-tensor)) + (axpy! alpha x (copy y)))) diff --git a/src/level-1/copy.lisp b/src/level-1/copy.lisp index 0800470..257bd3e 100644 --- a/src/level-1/copy.lisp +++ b/src/level-1/copy.lisp @@ -33,53 +33,38 @@ (deft/method t/blas-copy-func (sym complex-tensor) () 'zcopy) ;; -(deft/generic (t/blas-copy! #'subtypep) sym (sz x st-x y st-y)) -(deft/method t/blas-copy! (sym blas-numeric-tensor) (sz x st-x y st-y) - (let* ((decl (zipsym (list x y))) - (args (mapcar #'car decl)) - (func (macroexpand-1 `(t/blas-copy-func ,sym)))) - (let ((x (first args)) (y (second args))) +(deft/generic (t/blas-copy! #'subtypep) sym (x st-x y st-y)) +(deft/method t/blas-copy! (sym blas-numeric-tensor) (x st-x y st-y) + (let ((ncp? (null st-x))) + (using-gensyms (decl (x y)) `(let (,@decl) - (declare (type ,sym ,@args)) - (,func - (the index-type ,sz) - (the ,(store-type sym) (store ,x)) (the index-type ,st-x) - (the ,(store-type sym) (store ,y)) (the index-type ,st-y) - (head ,x) (head ,y)) + (declare (type ,sym ,@(unless ncp? `(,x)) ,y) + ,@(when ncp? `((type ,(field-type sym) ,x)))) + (let ((sto-x ,(if ncp? `(t/store-allocator ,sym 1) `(store ,x))) + (st-x ,(if ncp? 0 st-x))) + (declare (type ,(store-type sym) sto-x) + (type index-type st-x)) + ,@(when ncp? + `((t/store-set real-tensor ,x sto-x 0))) + (,(macroexpand-1 `(t/blas-copy-func ,sym)) + (the index-type (size ,y)) + (the ,(store-type sym) sto-x) (the index-type st-x) + (the ,(store-type sym) (store ,y)) (the index-type ,st-y) + ,(if ncp? 0 `(head ,x)) (head ,y))) ,y)))) -(deft/generic (t/blas-num-copy! #'subtypep) sym (sz x y st-y)) -(deft/method t/blas-num-copy! (sym blas-numeric-tensor) (sz x y st-y) - (let* ((decl (zipsym (list x y))) - (args (mapcar #'car decl)) - (func (macroexpand-1 `(t/blas-copy-func ,sym)))) - (let ((x (first args)) (y (second args))) - `(let (,@decl) - (declare (type ,sym ,y) - (type ,(field-type sym) ,x)) - (let ((sto-x (t/store-allocator ,sym 1))) - (declare (type ,(store-type sym) sto-x)) - (t/store-set ,sym ,x sto-x 0) - (,func - (the index-type ,sz) - (the ,(store-type sym) sto-x) 0 - (the ,(store-type sym) (store ,y)) (the index-type ,st-y) - 0 (head ,y))) - ,y)))) - ;; (deft/generic (t/copy! #'(lambda (a b) (strict-compare (list #'subtypep #'subtypep) a b))) (clx cly) (x y)) (deft/method t/copy! ((clx standard-tensor) (cly standard-tensor)) (x y) - (let* ((decl (zipsym (list x y))) - (args (mapcar #'car decl))) - (let ((x (first args)) (y (second args))) - `(let* (,@decl - (sto-x (store ,x)) - (sto-y (store ,y))) - (declare (type ,clx ,(first args)) - (type ,cly ,(second args)) - (type ,(store-type clx) sto-x) - (type ,(store-type cly) sto-y)) + (using-gensyms (decl (x y)) + `(let* (,@decl + (sto-x (store ,x)) + (sto-y (store ,y))) + (declare (type ,clx ,x) + (type ,cly ,y) + (type ,(store-type clx) sto-x) + (type ,(store-type cly) sto-y)) + (very-quickly (mod-dotimes (idx (dimensions ,x)) :with (linear-sums (of-x (strides ,x) (head ,x)) @@ -89,47 +74,45 @@ (unless (eq clx cly) `(t/strict-coerce (,(field-type clx) ,(field-type cly)) )) `(t/store-ref ,clx sto-x of-x)) - sto-y of-y)) - ,y)))) + sto-y of-y))) + ,y))) ;;Coercion messes up optimization in SBCL, so we specialize. (deft/method t/copy! ((clx real-numeric-tensor) (cly complex-numeric-tensor)) (x y) - (let* ((decl (zipsym (list x y))) - (args (mapcar #'car decl))) - (let ((x (first args)) (y (second args))) - `(let* (,@decl - (sto-x (store ,x)) - (sto-y (store ,y))) - (declare (type ,clx ,(first args)) - (type ,cly ,(second args)) - (type ,(store-type clx) sto-x) - (type ,(store-type cly) sto-y)) + (using-gensyms (decl (x y)) + `(let* (,@decl + (sto-x (store ,x)) + (sto-y (store ,y))) + (declare (type ,clx ,x) + (type ,cly ,y) + (type ,(store-type clx) sto-x) + (type ,(store-type cly) sto-y)) + (very-quickly (mod-dotimes (idx (dimensions ,x)) :with (linear-sums (of-x (strides ,x) (head ,x)) (of-y (strides ,y) (head ,y))) :do (t/store-set ,cly (the ,(field-type cly) (complex (t/coerce ,(store-element-type cly) (t/store-ref ,clx sto-x of-x)) (t/fid+ ,(store-element-type cly)))) - sto-y of-y)) - ,y)))) + sto-y of-y))) + ,y))) ;; (deft/method t/copy! ((clx t) (cly standard-tensor)) (x y) - (let* ((decl (zipsym (list x y))) - (args (mapcar #'car decl))) - (let ((x (first args)) (y (second args))) - `(let* (,@decl - (sto-y (store ,y)) - (cx (t/coerce ,(field-type cly) ,x))) - (declare (type ,cly ,(second args)) - (type ,(field-type cly) cx) - (type ,(store-type cly) sto-y)) - ;;This should be safe + (using-gensyms (decl (x y)) + `(let* (,@decl + (sto-y (store ,y)) + (cx (t/coerce ,(field-type cly) ,x))) + (declare (type ,cly ,y) + (type ,(field-type cly) cx) + (type ,(store-type cly) sto-y)) + ;;This should be safe + (very-quickly (mod-dotimes (idx (dimensions ,y)) :with (linear-sums (of-y (strides ,y) (head ,y))) - :do (t/store-set ,cly cx sto-y of-y)) - ,y)))) + :do (t/store-set ,cly cx sto-y of-y))) + ,y))) ;; (defmethod copy! :before ((x standard-tensor) (y standard-tensor)) @@ -142,21 +125,24 @@ (assert (and (member clx *tensor-type-leaves*) (member cly *tensor-type-leaves*)) nil 'tensor-abstract-class :tensor-class (list clx cly)) - (if (eq clx cly) - (progn - (compile-and-eval - `(defmethod copy! ((x ,clx) (y ,cly)) - ,(recursive-append - (when (subtypep clx 'blas-numeric-tensor) - `(if-let (strd (and (call-fortran? x (t/l1-lb ,clx)) (blas-copyablep x y))) - (let ((sz (size x))) (t/blas-copy! ,clx sz x (first strd) y (second strd))))) - `(very-quickly (t/copy! (,clx ,cly) x y))) - y))) - (compile-and-eval - `(defmethod copy! ((x ,clx) (y ,cly)) - (t/copy! (,clx ,cly) x y) - y))) - (copy! x y))) + (cond + ((eq clx cly) + (compile-and-eval + `(defmethod copy! ((x ,clx) (y ,cly)) + ,(recursive-append + (when (subtypep clx 'blas-numeric-tensor) + `(if-let (strd (and (call-fortran? x (t/l1-lb ,clx)) (blas-copyablep x y))) + (t/blas-copy! ,clx x (first strd) y (second strd)))) + `(very-quickly (t/copy! (,clx ,cly) x y))) + y))) + ((coerceable? clx cly) + (compile-and-eval + `(defmethod copy! ((x ,clx) (y ,cly)) + (t/copy! (,clx ,cly) x y) + y))) + (t + (error "Don't know how to copy from ~a to ~a" clx cly)))) + (copy! x y)) (defmethod copy! ((x t) (y standard-tensor)) (let ((cly (class-name (class-of y)))) @@ -167,7 +153,7 @@ ,(recursive-append (when (subtypep cly 'blas-numeric-tensor) `(if-let (strd (and (call-fortran? y (t/l1-lb ,cly)) (consecutive-storep y))) - (let ((sz (size y))) (t/blas-num-copy! ,cly sz x y strd)))) + (t/blas-copy! ,cly x nil y strd))) `(very-quickly (t/copy! (t ,cly) x y))))) (copy! x y))) diff --git a/src/level-1/dot.lisp b/src/level-1/dot.lisp index a7ac53e..3aa4a2f 100644 --- a/src/level-1/dot.lisp +++ b/src/level-1/dot.lisp @@ -36,43 +36,38 @@ (deft/generic (t/blas-dot #'subtypep) sym (x y &optional conjp)) (deft/method t/blas-dot (sym blas-numeric-tensor) (x y &optional (conjp t)) - (let* ((decl (zipsym (list x y))) - (args (mapcar #'car decl)) - (func (macroexpand-1 `(t/blas-dot-func ,sym ,conjp)))) - (let ((x (first args)) (y (second args))) - `(let (,@decl) - (declare (type ,sym ,@args)) - (,func - (aref (the index-store-vector (dimensions ,x)) 0) - (the ,(store-type sym) (store ,x)) (aref (the index-store-vector (strides ,x)) 0) - (the ,(store-type sym) (store ,y)) (aref (the index-store-vector (strides ,y)) 0) - (head ,x) (head ,y)))))) + (using-gensyms (decl (x y)) + `(let (,@decl) + (declare (type ,sym ,x ,y)) + (,(macroexpand-1 `(t/blas-dot-func ,sym ,conjp)) + (aref (the index-store-vector (dimensions ,x)) 0) + (the ,(store-type sym) (store ,x)) (aref (the index-store-vector (strides ,x)) 0) + (the ,(store-type sym) (store ,y)) (aref (the index-store-vector (strides ,y)) 0) + (head ,x) (head ,y))))) (deft/generic (t/dot #'subtypep) sym (x y &optional conjp)) (deft/method t/dot (sym standard-tensor) (x y &optional (conjp t)) - (let* ((decl (zipsym (list x y))) - (args (mapcar #'car decl))) - (let ((x (first args)) (y (second args))) - `(let (,@decl) - (declare (type ,sym ,@args)) - (let ((sto-x (store ,x)) - (stp-x (aref (the index-store-vector (strides ,x)) 0)) - (of-x (head ,x)) - (sto-y (store ,y)) - (stp-y (aref (the index-store-vector (strides ,y)) 0)) - (of-y (head ,y)) - (dot (t/fid+ ,(field-type sym)))) - (declare (type ,(store-type sym) sto-x sto-y) - (type index-type stp-x stp-y of-x of-y) - (type ,(field-type sym) dot)) - (loop :repeat (aref (the index-store-vector (dimensions ,x)) 0) - :do (setf dot (t/f+ ,(field-type sym) dot - (t/f* ,(field-type sym) - ,(recursive-append (when conjp `(t/fc ,(field-type sym))) `(t/store-ref ,sym sto-x of-x)) - (t/store-ref ,sym sto-y of-y))) - of-x (+ of-x stp-x) - of-y (+ of-y stp-y))) - dot))))) + (using-gensyms (decl (x y)) + `(let (,@decl) + (declare (type ,sym ,x ,y)) + (let ((sto-x (store ,x)) + (stp-x (aref (the index-store-vector (strides ,x)) 0)) + (of-x (head ,x)) + (sto-y (store ,y)) + (stp-y (aref (the index-store-vector (strides ,y)) 0)) + (of-y (head ,y)) + (dot (t/fid+ ,(field-type sym)))) + (declare (type ,(store-type sym) sto-x sto-y) + (type index-type stp-x stp-y of-x of-y) + (type ,(field-type sym) dot)) + (loop :repeat (aref (the index-store-vector (dimensions ,x)) 0) + :do (setf dot (t/f+ ,(field-type sym) dot + (t/f* ,(field-type sym) + ,(recursive-append (when conjp `(t/fc ,(field-type sym))) `(t/store-ref ,sym sto-x of-x)) + (t/store-ref ,sym sto-y of-y))) + of-x (+ of-x stp-x) + of-y (+ of-y stp-y))) + dot)))) ;;---------------------------------------------------------------;; (defgeneric dot (x y &optional conjugate-p) (:documentation @@ -137,8 +132,8 @@ ;;You pay the piper if you like mixing types. ;;This is (or should be) a rare enough to not matter. ((coerceable? clx cly) - (dot (copy! x (zeros (dimensions x) cly)) y conjugate-p)) + (dot (coerce-tensor x cly) y conjugate-p)) ((coerceable? cly clx) - (dot x (copy! y (zeros (dimensions y) clx)) conjugate-p)) + (dot x (coerce-tensor y clx) conjugate-p)) (t (error "Don't know how to compute the dot product of ~a , ~a." clx cly))))) diff --git a/src/level-1/maker.lisp b/src/level-1/maker.lisp index 21959a8..46a3f76 100644 --- a/src/level-1/maker.lisp +++ b/src/level-1/maker.lisp @@ -22,10 +22,11 @@ (definline zeros (dims &optional (type 'real-tensor)) (let ((*check-after-initializing?* nil)) - (etypecase dims - (vector - (zeros-generic (lvec->list dims) type)) - (cons - (zeros-generic dims type)) - (fixnum - (zeros-generic (list dims) type))))) + (let ((type (etypecase type (standard-class (class-name type)) (symbol type)))) + (etypecase dims + (vector + (zeros-generic (lvec->list dims) type)) + (cons + (zeros-generic dims type)) + (fixnum + (zeros-generic (list dims) type)))))) diff --git a/src/level-1/scal.lisp b/src/level-1/scal.lisp index 72a7962..85be999 100644 --- a/src/level-1/scal.lisp +++ b/src/level-1/scal.lisp @@ -25,9 +25,51 @@ ;;; ENHANCEMENTS, OR MODIFICATIONS. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (in-package #:matlisp) +(deft/generic (t/blas-scal-func #'subtypep) sym ()) +(deft/method t/blas-scal-func (sym real-tensor) () + 'descal) + +(deft/method t/blas-scal-func (sym complex-tensor) () + 'zescal) +;; +(deft/generic (t/blas-scal! #'subtypep) sym (sz alpha x st-x)) + +(deft/generic (t/blas-axpy! #'subtypep) sym (a x st-x y st-y)) +(deft/method t/blas-axpy! (sym blas-numeric-tensor) (a x st-x y st-y) + (let ((apy? (null x))) + (using-gensyms (decl (a x y)) + `(let (,@decl) + (declare (type ,sym ,@(unless apy? `(,x)) ,y) + ,@(when apy? `((ignore ,x)))) + (let ((sto-x ,(if apy? `(t/store-allocator ,sym 1) `(store ,x))) + (st-x ,(if apy? 0 st-x))) + (declare (type ,(store-type sym) sto-x) + (type index-type st-x)) + ,@(when apy? + `((t/store-set real-tensor (t/fid* ,(field-type sym)) sto-x 0))) + (,(macroexpand-1 `(t/blas-axpy-func ,sym)) + (the index-type (size ,y)) + (the ,(field-type sym) ,a) + sto-x st-x + (the ,(store-type sym) (store ,y)) (the index-type ,st-y) + ,(if apy? 0 `(head ,x)) (head ,y)) + ,y))))) + +(deft/method t/blas-scal! (sym blas-numeric-tensor) (sz a x st-x) + (using-gensyms (decl (x)) + `(let (,@decl) + (declare (type ,sym ,x)) + (,(macroexpand-1 `(t/blas-scal-func ,sym)) + (the index-type ,sz) + (the ,(field-type sym) ,a) + (the ,(store-type sym) (store ,x)) (the index-type ,st-x) + (head ,x)) + ,x))) + + + (defmacro generate-typed-scal! (func (tensor-class fortran-func fortran-lb)) (let* ((opt (get-tensor-class-optimization-hashtable tensor-class))) (assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class) @@ -190,10 +232,6 @@ (real-tensor dediv *real-l1-fcall-lb*)) ;;Complex -(definline zordscal (nele alpha x incx &optional hd-x) - (if (zerop (imagpart alpha)) - (zdscal nele (realpart alpha) x incx hd-x) - (zscal nele alpha x incx hd-x))) (generate-typed-num-scal! complex-typed-num-scal! (complex-tensor zordscal *complex-l1-fcall-lb*)) diff --git a/src/level-1/swap.lisp b/src/level-1/swap.lisp index c6c5321..a177a03 100644 --- a/src/level-1/swap.lisp +++ b/src/level-1/swap.lisp @@ -33,41 +33,37 @@ (deft/method t/blas-swap-func (sym complex-tensor) () 'zswap) ;; -(deft/generic (t/blas-swap! #'subtypep) sym (sz x st-x y st-y)) -(deft/method t/blas-swap! (sym blas-numeric-tensor) (sz x st-x y st-y) - (let* ((decl (zipsym (list x y))) - (args (mapcar #'car decl)) - (func (macroexpand-1 `(t/blas-swap-func ,sym)))) - (let ((x (first args)) (y (second args))) - `(let (,@decl) - (declare (type ,sym ,@args)) - (,func - (the index-type ,sz) - (the ,(store-type sym) (store ,x)) (the index-type ,st-x) - (the ,(store-type sym) (store ,y)) (the index-type ,st-y) - (head ,x) (head ,y)) - ,y)))) +(deft/generic (t/blas-swap! #'subtypep) sym (x st-x y st-y)) +(deft/method t/blas-swap! (sym blas-numeric-tensor) (x st-x y st-y) + (using-gensyms (decl (x y)) + `(let (,@decl) + (declare (type ,sym ,x ,y)) + (,(macroexpand-1 `(t/blas-swap-func ,sym)) + (the index-type (size ,y)) + (the ,(store-type sym) (store ,x)) (the index-type ,st-x) + (the ,(store-type sym) (store ,y)) (the index-type ,st-y) + (head ,x) (head ,y)) + ,y))) (deft/generic (t/swap! #'subtypep) sym (x y)) (deft/method t/swap! (sym standard-tensor) (x y) - (let* ((decl (zipsym (list x y))) - (args (mapcar #'car decl))) - (let ((x (first args)) (y (second args))) - `(let* (,@decl - (sto-x (store ,x)) - (sto-y (store ,y))) - (declare (type ,sym ,@args) + (using-gensyms (decl (x y)) + `(let (,@decl + (sto-x (store ,x)) + (sto-y (store ,y))) + (declare (type ,sym ,x ,y) (type ,(store-type sym) sto-x sto-y)) - (mod-dotimes (idx (dimensions ,x)) - :with (linear-sums - (of-x (strides ,x) (head ,x)) - (of-y (strides ,y) (head ,y))) - :do (let-typed ((y-val (t/store-ref ,sym sto-y of-y) :type ,(field-type sym))) - (t/store-set ,sym - (t/store-ref ,sym sto-x of-x) sto-y of-y) - (t/store-set ,sym - y-val sto-x of-x))) - ,y)))) + (very-quickly + (mod-dotimes (idx (dimensions ,x)) + :with (linear-sums + (of-x (strides ,x) (head ,x)) + (of-y (strides ,y) (head ,y))) + :do (let-typed ((y-val (t/store-ref ,sym sto-y of-y) :type ,(field-type sym))) + (t/store-set ,sym + (t/store-ref ,sym sto-x of-x) sto-y of-y) + (t/store-set ,sym + y-val sto-x of-x))) + ,y)))) ;;---------------------------------------------------------------;; (defmethod swap! :before ((x standard-tensor) (y standard-tensor)) (assert (very-quickly (lvec-eq (the index-store-vector (dimensions x)) (the index-store-vector (dimensions y)) #'=)) nil @@ -86,8 +82,8 @@ ,(recursive-append (when (subtypep clx 'blas-numeric-tensor) `(if-let (strd (and (call-fortran? x (t/l1-lb ,clx)) (blas-copyablep x y))) - (let ((sz (size x))) (t/blas-swap! ,clx sz x (first strd) y (second strd))))) - `(very-quickly (t/swap! ,clx x y))) + (t/blas-swap! ,clx x (first strd) y (second strd)))) + `(t/swap! ,clx x y)) y)) (swap! x y)) ;;It is silly to swap a real vector with a complex one, no? commit d7210a4b81356e32907afde8bcd13d4cbf97dd00 Author: Akshay Srinivasan <aks...@gm...> Date: Fri Jun 21 03:54:09 2013 -0700 Added axpy! template. diff --git a/packages.lisp b/packages.lisp index 4168ed9..5c7413f 100644 --- a/packages.lisp +++ b/packages.lisp @@ -84,7 +84,7 @@ #:lvec->list #:lvec->list! #:compile-and-eval ;;Macros - #:when-let #:if-let #:if-ret #:with-gensyms #:let-rec + #:when-let #:if-let #:if-ret #:with-gensyms #:let-rec #:using-gensyms #:mlet* #:make-array-allocator #:let-typed #:let*-typed #:nconsc #:define-constant #:macrofy #:looped-mapcar #:defun-compiler-macro diff --git a/src/base/template.lisp b/src/base/template.lisp index a190f46..bdf0d06 100644 --- a/src/base/template.lisp +++ b/src/base/template.lisp @@ -50,7 +50,7 @@ (compile-and-eval `(defmethod fconj ((x ,clname)) (t/fc ,clname x))) - (fconj x)))) + (fc x)))) (deft/generic (t/f= #'subtypep) ty (&rest nums)) (deft/method t/f= (ty number) (&rest nums) diff --git a/src/level-1/axpy.lisp b/src/level-1/axpy.lisp index 25966de..a604af8 100644 --- a/src/level-1/axpy.lisp +++ b/src/level-1/axpy.lisp @@ -25,123 +25,81 @@ ;;; ENHANCEMENTS, OR MODIFICATIONS. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (in-package #:matlisp) -(defmacro generate-typed-axpy! (func (tensor-class blas-func fortran-lb)) - ;;Be very careful when using functions generated by this macro. - ;;Indexes can be tricky and this has no safety net - ;;Use only after checking the arguments for compatibility. - (let* ((opt (get-tensor-class-optimization-hashtable tensor-class))) - (assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class) - `(progn - (eval-when (:compile-toplevel :load-toplevel :execute) - (let ((opt (get-tensor-class-optimization-hashtable ',tensor-class))) - (assert opt nil 'tensor-cannot-find-optimization :tensor-class ',tensor-class) - (setf (getf opt :axpy) ',func - (get-tensor-class-optimization ',tensor-class) opt))) - (defun ,func (alpha from to) - (declare (type ,tensor-class from to) - (type ,(getf opt :element-type) alpha)) - ,(let - ((lisp-routine - `(let ((f-sto (store from)) - (t-sto (store to))) - (declare (type ,(linear-array-type (getf opt :store-type)) f-sto t-sto)) - (very-quickly - (mod-dotimes (idx (dimensions from)) - with (linear-sums - (f-of (strides from) (head from)) - (t-of (strides to) (head to))) - do (let ((f-val (,(getf opt :reader) f-sto f-of)) - (t-val (,(getf opt :reader) t-sto t-of))) - (declare (type ,(getf opt :element-type) f-val t-val)) - (let ((t-new (,(getf opt :f+) (,(getf opt :f*) f-val alpha) t-val))) - (declare (type ,(getf opt :element-type) t-new)) - (,(getf opt :value-writer) t-new t-sto t-of)))))))) - (if blas-func - `(let* ((call-fortran? (> (number-of-elements to) - ,fortran-lb)) - (strd-p (when call-fortran? (blas-copyable-p from to)))) - (cond - ((and call-fortran? strd-p) - (,blas-func (number-of-elements from) alpha - (store from) (first strd-p) - (store to) (second strd-p) - (head from) (head to))) - (t - ,lisp-routine))) - lisp-routine)) - to)))) - -(defmacro generate-typed-num-axpy! (func (tensor-class blas-func fortran-lb)) - ;;Be very careful when using functions generated by this macro. - ;;Indexes can be tricky and this has no safety net - ;;(you don't see a matrix-ref do you ?) - ;;Use only after checking the arguments for compatibility. - (let* ((opt (get-tensor-class-optimization tensor-class))) - (assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class) - `(progn - (eval-when (:compile-toplevel :load-toplevel :execute) - (let ((opt (get-tensor-class-optimization-hashtable ',tensor-class))) - (assert opt nil 'tensor-cannot-find-optimization :tensor-class ',tensor-class) - (setf (getf opt :num-axpy) ',func - (get-tensor-class-optimization ',tensor-class) opt))) - (defun ,func (num-from to) - (declare (type ,tensor-class to) - (type ,(getf opt :element-type) num-from)) - ,(let - ((lisp-routine - `(let-typed - ((t-sto (store to) :type ,(linear-array-type (getf opt :store-type)))) - (very-quickly - (mod-dotimes (idx (dimensions to)) - with (linear-sums - (t-of (strides to) (head to))) - do (let-typed - ((val (,(getf opt :reader) t-sto t-of) :type ,(getf opt :element-type))) - (,(getf opt :value-writer) (,(getf opt :f+) num-from val) t-sto t-of))))))) - (if blas-func - `(let* ((call-fortran? (> (number-of-elements to) ,fortran-lb)) - (min-strd (when call-fortran? (consecutive-store-p to)))) - (cond - ((and call-fortran? min-strd) - (let ((num-array (,(getf opt :store-allocator) 1))) - (declare (type ,(linear-array-type (getf opt :store-type)) num-array)) - (let-typed ((id (,(getf opt :fid+)) :type ,(getf opt :element-type))) - (,(getf opt :value-writer) id num-array 0)) - (,blas-func (number-of-elements to) num-from - num-array 0 - (store to) min-strd - 0 (head to)))) - (t - ,lisp-routine))) - lisp-routine)) - to)))) - -;;Real -(generate-typed-axpy! real-typed-axpy! - (real-tensor daxpy *real-l1-fcall-lb*)) - -(generate-typed-num-axpy! real-typed-num-axpy! - (real-tensor daxpy *real-l1-fcall-lb*)) - -;;Complex -(generate-typed-axpy! complex-typed-axpy! - (complex-tensor zaxpy *complex-l1-fcall-lb*)) - -(generate-typed-num-axpy! complex-typed-num-axpy! - (complex-tensor zaxpy *complex-l1-fcall-lb*)) - -;;Symbolic -#+maxima -(progn - (generate-typed-axpy! symbolic-typed-axpy! - (symbolic-tensor nil 0)) - - (generate-typed-num-axpy! symbolic-typed-num-axpy! - (symbolic-tensor nil 0))) - +(deft/generic (t/blas-axpy-func #'subtypep) sym ()) +(deft/method t/blas-axpy-func (sym real-tensor) () + 'daxpy) +(deft/method t/blas-axpy-func (sym complex-tensor) () + 'zaxpy) +;; + +(deft/generic (t/blas-axpy! #'subtypep) sym (sz a x st-x y st-y)) +(deft/method t/blas-axpy! (sym blas-numeric-tensor) (sz a x st-x y st-y) + (using-gensyms (decl (x y)) + `(let (,@decl) + (declare (type ,sym ,x ,y)) + (,(macroexpand-1 `(t/blas-axpy-func ,sym)) + (the index-type ,sz) + (the ,(field-type sym) ,a) + (the ,(store-type sym) (store ,x)) (the index-type ,st-x) + (the ,(store-type sym) (store ,y)) (the index-type ,st-y) + (head ,x) (head ,y)) + ,y))) + +(deft/generic (t/blas-apy! #'subtypep) sym (sz a y st-y)) +(deft/method t/blas-apy! (sym blas-numeric-tensor) (sz a y st-y) + (using-gensyms (decl (a y)) + `(let (,@decl) + (declare (type ,sym ,y) + (type ,(field-type sym) ,a)) + (let ((sto-a (t/store-allocator ,sym 1))) + (declare (type ,(store-type sym) sto-a)) + (t/store-set ,sym ,a sto-a 0) + (,(macroexpand-1 `(t/blas-axpy-func ,sym)) + (the index-type ,sz) + (t/fid* ,(field-type sym)) + (the ,(store-type sym) sto-a) 0 + (the ,(store-type sym) (store ,y)) (the index-type ,st-y) + 0 (head ,y))) + ,y))) + +(deft/generic (t/axpy! #'subtypep) sym (a x y)) +(deft/method t/axpy! (sym standard-tensor) (a x y) + (using-gensyms (decl (a x y)) + `(let (,@decl) + (declare (type ,sym ,x ,y) + (type ,(field-type sym) ,a)) + (let ((sto-x (store ,x)) + (sto-y (store ,y))) + (declare (type ,(store-type sym) sto-x sto-y)) + (mod-dotimes (idx (dimensions ,x)) + :with (linear-sums + (of-x (strides ,x) (head ,x)) + (of-y (strides ,y) (head ,y))) + :do (t/store-set ,sym (t/f+ ,(field-type sym) + (t/f* ,(field-type sym) + ,a (t/store-ref ,sym sto-x of-x)) + (t/store-ref ,sym sto-y of-y)) + sto-y of-y))) + ,y))) + +(deft/generic (t/apy! #'subtypep) sym (a y)) +(deft/method t/apy! (sym standard-tensor) (a y) + (using-gensyms (decl (a y)) + `(let (,@decl) + (declare (type ,sym ,y) + (type ,(field-type sym) ,a)) + (let ((sto-y (store ,y))) + (declare (type ,(store-type sym) sto-y)) + (mod-dotimes (idx (dimensions ,y)) + :with (linear-sums + (of-y (strides ,y) (head ,y))) + :do (t/store-set ,sym (t/f+ ,(field-type sym) + ,a + (t/store-ref ,sym sto-y of-y)) + sto-y of-y))) + ,y))) ;;---------------------------------------------------------------;; (defgeneric axpy! (alpha x y) diff --git a/src/utilities/macros.lisp b/src/utilities/macros.lisp index 259fb95..a0230d0 100644 --- a/src/utilities/macros.lisp +++ b/src/utilities/macros.lisp @@ -203,6 +203,11 @@ symlist) ,@body)) +(defmacro using-gensyms ((decl (&rest syms)) &rest body) + `(let ((,decl (zipsym (list ,@syms)))) + (destructuring-bind (,@syms) (mapcar #'car ,decl) + ,@body))) + (defmacro nconsc (var &rest args) " Macro to do setf and nconc for destructive list updates. If @arg{var} diff --git a/src/utilities/template.lisp b/src/utilities/template.lisp index 0392817..99f029c 100644 --- a/src/utilities/template.lisp +++ b/src/utilities/template.lisp @@ -64,7 +64,7 @@ `(eval-when (:compile-toplevel :load-toplevel :execute) (setf (gethash ',name *template-table*) (list :lambda-list (list ',disp ',args) :predicate ,predicate :sorter ,(or sorter predicate) :methods nil)) (defmacro ,name (&whole ,warg-sym ,disp-arg ,@args) - (declare (ignore ,@(remove-if #'(lambda (x) (member x cl:lambda-list-keywords)) args))) + (declare (ignore ,@(remove-if #'(lambda (x) (member x cl:lambda-list-keywords)) args) ,@(when (consp disp) disp))) (let* ((,pred-sym (preprocess-t/dispatch ',name ,disp-far)) (,meth-sym (compute-t/dispatch ',name ,pred-sym))) (apply ,meth-sym (cons ,pred-sym (cddr ,warg-sym))))))))) commit 1407d41f3f3150a905e8cf33e07db5042651f8ae Author: Akshay Srinivasan <aks...@gm...> Date: Fri Jun 21 03:38:54 2013 -0700 Cleaned up mod-dotimes. diff --git a/src/base/loopy.lisp b/src/base/loopy.lisp index f68a66d..2e3300c 100644 --- a/src/base/loopy.lisp +++ b/src/base/loopy.lisp @@ -1,6 +1,6 @@ (in-package #:matlisp) -(defmacro mod-dotimes ((idx dims) &body body) +(defmacro mod-dotimes ((idx dims &key (loop-order *default-stride-ordering*)) &body body) " (mod-dotimes (idx {seq}) compound-form*) @@ -31,19 +31,14 @@ Make sure that \"do\" is specified at the end. Parser stops at the first 'do it finds. " - (check-type idx symbol) + (check-type idx symbol) (labels ((parse-code (body ret) (cond ((null body) (values nil ret)) ((member (car body) '(with :with)) (multiple-value-bind (indic decl) (parse-with (cadr body)) - (setf (getf ret indic) decl)) - (parse-code (cddr body) ret)) - ;;Let's not do too much - #+nil - ((eq (car body) 'finally) - (setf (getf ret :finally) (second body)) + (setf (getf ret indic) (append (getf ret indic) decl))) (parse-code (cddr body) ret)) ((member (car body) '(do :do)) (values (cadr body) ret)) @@ -52,74 +47,77 @@ (cond ((member (car code) '(linear-sums :linear-sums)) (values :linear-sums - (loop for decl in (cdr code) - collect (destructuring-bind (offst strds &optional (init 0)) decl - (list :offset-sym offst - :offset-init init - :stride-sym (gensym (string+ (symbol-name offst) "-stride")) - :stride-expr strds))))) - ((and (member (car code) '(loop-order :loop-order)) - (member (cadr code) '(:row-major :col-major))) - (values :loop-order (second code))) - ;;Useless without a finally clause - #+nil - ((eq (car code) 'variables) - (values :variables - (loop for decl in (cdr code) - collect (destructuring-bind (sym init &key type) decl - (list :variable sym - :init init - :type type))))) + (loop :for decl :in (cdr code) + :collect (destructuring-bind (offst strds &optional (init 0)) decl + (list :offset-sym offst + :offset-init init + :stride-sym (gensym (string+ (symbol-name offst) "-stride")) + :stride-expr strds))))) (t (error 'unknown-token :token (car code) :message "Error in macro: mod-dotimes -> parse-with.~%"))))) (multiple-value-bind (code sdecl) (parse-code body nil) - (with-gensyms (dims-sym rank-sym count-sym) - `(let ((,dims-sym ,dims)) - (declare (type index-store-vector ,dims-sym)) - (let ((,rank-sym (length ,dims-sym))) - (declare (type index-type ,rank-sym)) - (let ((,idx (allocate-index-store ,rank-sym)) - ,@(mapcar #'(lambda (x) `(,(getf x :stride-sym) ,(getf x :stride-expr))) (getf sdecl :linear-sums)) - ,@(mapcar #'(lambda (x) `(,(getf x :variable) ,(getf x :init))) (getf sdecl :variables))) - (declare (type index-store-vector ,idx) - ,@(when (getf sdecl :linear-sums) - `((type index-store-vector ,@(mapcar #'(lambda (x) (getf x :stride-sym)) (getf sdecl :linear-sums))))) - ,@(loop for x in (getf sdecl :variables) - unless (null (getf x :type)) - collect `(type ,(getf x :type) ,(getf x :variable)))) - (loop ,@(loop for decl in (getf sdecl :linear-sums) - append `(with ,(getf decl :offset-sym) of-type index-type = ,(getf decl :offset-init))) - ,@(unless (null code) - `(do (,@code))) - while (very-quickly - ,(append - (if (member (getf sdecl :loop-order) '(nil :row-major)) - `(loop for ,count-sym of-type index-type from (1- ,rank-sym) downto 0) - `(loop for ,count-sym of-type index-type from 0 below ,rank-sym)) - `(do - (if (= (aref ,idx ,count-sym) (1- (aref ,dims-sym ,count-sym))) - (progn - (setf (aref ,idx ,count-sym) 0) - ,@(loop - for decl in (getf sdecl :linear-sums) - collect (let ((cstrd (gensym (string+ "cur-" (symbol-name (getf decl :stride-sym)))))) - `(let ((,cstrd (aref ,(getf decl :stride-sym) ,count-sym))) - (declare (type index-type ,cstrd)) - (unless (= ,cstrd 0) - (decf ,(getf decl :offset-sym) (the index-type (* ,cstrd (1- (aref ,dims-sym ,count-sym)))))))))) - (progn - (incf (aref ,idx ,count-sym)) - ,@(loop - for decl in (getf sdecl :linear-sums) - collect (let ((cstrd (gensym (string+ "cur-" (symbol-name (getf decl :stride-sym)))))) - `(let ((,cstrd (aref ,(getf decl :stride-sym) ,count-sym))) - (declare (type index-type ,cstrd)) - (unless (= ,cstrd 0) - (incf ,(getf decl :offset-sym) ,cstrd))))) - (return t))) - finally (return nil)))) - ,@(unless (null (getf sdecl :finally)) - `(finally (,@(getf sdecl :finally)))))))))))) - + (let ((loop-perm (unless (member loop-order '(:row-major :col-major)) + ;;Assumed to be a permutation action store + (prog1 loop-order + (setq loop-order nil))))) + (with-gensyms (perm-sym loopi-sym dims-sym rank-sym count-sym) + `(let ((,dims-sym ,dims)) + (declare (type index-store-vector ,dims-sym)) + (let ((,rank-sym (length ,dims-sym)) + ,@(when loop-perm + `((,perm-sym ,loop-perm)))) + (declare (type index-type ,rank-sym) + ,@(when loop-perm + `((type pindex-store-vector ,perm-sym)))) + ,@(when loop-perm + `((assert (<= (length ,perm-sym) ,rank-sym) nil 'permutation-permute-error))) + (let ((,idx (allocate-index-store ,rank-sym)) + ,@(when loop-perm `((,loopi-sym (allocate-index-store ,rank-sym)))) + ,@(mapcar #'(lambda (x) `(,(getf x :stride-sym) ,(getf x :stride-expr))) (getf sdecl :linear-sums)) + ,@(mapcar #'(lambda (x) `(,(getf x :variable) ,(getf x :init))) (getf sdecl :variables))) + (declare (type index-store-vector ,idx ,@(when loop-perm `(,loopi-sym))) + ,@(when (getf sdecl :linear-sums) + `((type index-store-vector ,@(mapcar #'(lambda (x) (getf x :stride-sym)) (getf sdecl :linear-sums))))) + ,@(loop :for x :in (getf sdecl :variables) + :unless (null (getf x :type)) + :collect `(type ,(getf x :type) ,(getf x :variable)))) + ,@(when loop-perm + `((very-quickly + (loop :for i :of-type index-type :from 0 :below ,rank-sym :do (setf (aref ,loopi-sym i) i)) + (apply-action! ,loopi-sym ,perm-sym)))) + (loop ,@(loop :for decl :in (getf sdecl :linear-sums) + :append `(:with ,(getf decl :offset-sym) :of-type index-type := ,(getf decl :offset-init))) + ,@(unless (null code) + `(:do (,@code))) + :while (very-quickly + ,(append + (if loop-perm + `(loop :for ,count-sym :of-type index-type :across ,loopi-sym) + (ecase loop-order + (:row-major `(loop :for ,count-sym :of-type index-type :from (1- ,rank-sym) :downto 0)) + (:col-major `(loop :for ,count-sym :of-type index-type :from 0 :below ,rank-sym)))) + `(:do + (if (= (aref ,idx ,count-sym) (1- (aref ,dims-sym ,count-sym))) + (progn + (setf (aref ,idx ,count-sym) 0) + ,@(loop + :for decl :in (getf sdecl :linear-sums) + :collect (let ((cstrd (gensym (string+ "cur-" (symbol-name (getf decl :stride-sym)))))) + `(let ((,cstrd (aref ,(getf decl :stride-sym) ,count-sym))) + (declare (type index-type ,cstrd)) + (unless (= ,cstrd 0) + (decf ,(getf decl :offset-sym) (the index-type (* ,cstrd (1- (aref ,dims-sym ,count-sym)))))))))) + (progn + (incf (aref ,idx ,count-sym)) + ,@(loop + :for decl :in (getf sdecl :linear-sums) + :collect (let ((cstrd (gensym (string+ "cur-" (symbol-name (getf decl :stride-sym)))))) + `(let ((,cstrd (aref ,(getf decl :stride-sym) ,count-sym))) + (declare (type index-type ,cstrd)) + (unless (= ,cstrd 0) + (incf ,(getf decl :offset-sym) ,cstrd))))) + (return t))) + :finally (return nil))))))))))))) + (defmacro list-loop ((idx ele lst) &rest body) " (list-loop (idx ele {list}) compound-form*) commit 4248b0bfbfb4fda8e99fee6edad8383f2afcf606 Author: Akshay Srinivasan <aks...@gm...> Date: Wed Jun 19 02:40:59 2013 -0700 Migrated swap. diff --git a/matlisp.asd b/matlisp.asd index 1526b85..832ab71 100644 --- a/matlisp.asd +++ b/matlisp.asd @@ -139,9 +139,10 @@ :depends-on ("maker")) (:file "dot" :depends-on ("maker")) + (:file "swap") #+nil ( - (:file "swap") + (:file "realimag" :depends-on ("copy")) (:file "scal" diff --git a/src/level-1/swap.lisp b/src/level-1/swap.lisp index d9febc0..c6c5321 100644 --- a/src/level-1/swap.lisp +++ b/src/level-1/swap.lisp @@ -25,70 +25,70 @@ ;;; ENHANCEMENTS, OR MODIFICATIONS. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (in-package #:matlisp) -(defmacro generate-typed-swap! (func (tensor-class blas-func fortran-lb)) - ;;Be very careful when using functions generated by this macro. - ;;Indexes can be tricky and this has no safety net - ;;Use only after checking the arguments for compatibility. - (let* ((opt (get-tensor-class-optimization-hashtable tensor-class))) - (assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class) - `(progn - (eval-when (:compile-toplevel :load-toplevel :execute) - (let ((opt (get-tensor-class-optimization-hashtable ',tensor-class))) - (assert opt nil 'tensor-cannot-find-optimization :tensor-class ',tensor-class) - (setf (getf opt :swap) ',func - (get-tensor-class-optimization ',tensor-class) opt))) - (defun ,func (x y) - (declare (type ,tensor-class x y)) - ,(let - ((lisp-routine - `(let ((f-sto (store x)) - (t-sto (store y))) - (declare (type ,(linear-array-type (getf opt :store-type)) f-sto t-sto)) - (very-quickly - (mod-dotimes (idx (dimensions x)) - with (linear-sums - (f-of (strides x) (head x)) - (t-of (strides y) (head y))) - do (,(getf opt :swapper) f-sto f-of t-sto t-of)))))) - (if blas-func - `(let* ((call-fortran? (> (number-of-elements x) ,fortran-lb)) - (strd-p (when call-fortran? (blas-copyable-p x y)))) - (cond - ((and strd-p call-fortran?) - (,blas-func (number-of-elements x) (store x) (first strd-p) (store y) (second strd-p) (head x) (head y))) - (t - ,lisp-routine))) - lisp-routine)) - y)))) - -(generate-typed-swap! real-typed-swap! - (real-tensor dswap *real-l1-fcall-lb*)) - -(generate-typed-swap! complex-typed-swap! - (complex-tensor zswap *complex-l1-fcall-lb*)) - -#+maxima -(generate-typed-swap! symbolic-typed-swap! - (symbolic-tensor nil 0)) - +(deft/generic (t/blas-swap-func #'subtypep) sym ()) +(deft/method t/blas-swap-func (sym real-tensor) () + 'dswap) +(deft/method t/blas-swap-func (sym complex-tensor) () + 'zswap) +;; +(deft/generic (t/blas-swap! #'subtypep) sym (sz x st-x y st-y)) +(deft/method t/blas-swap! (sym blas-numeric-tensor) (sz x st-x y st-y) + (let* ((decl (zipsym (list x y))) + (args (mapcar #'car decl)) + (func (macroexpand-1 `(t/blas-swap-func ,sym)))) + (let ((x (first args)) (y (second args))) + `(let (,@decl) + (declare (type ,sym ,@args)) + (,func + (the index-type ,sz) + (the ,(store-type sym) (store ,x)) (the index-type ,st-x) + (the ,(store-type sym) (store ,y)) (the index-type ,st-y) + (head ,x) (head ,y)) + ,y)))) + +(deft/generic (t/swap! #'subtypep) sym (x y)) +(deft/method t/swap! (sym standard-tensor) (x y) + (let* ((decl (zipsym (list x y))) + (args (mapcar #'car decl))) + (let ((x (first args)) (y (second args))) + `(let* (,@decl + (sto-x (store ,x)) + (sto-y (store ,y))) + (declare (type ,sym ,@args) + (type ,(store-type sym) sto-x sto-y)) + (mod-dotimes (idx (dimensions ,x)) + :with (linear-sums + (of-x (strides ,x) (head ,x)) + (of-y (strides ,y) (head ,y))) + :do (let-typed ((y-val (t/store-ref ,sym sto-y of-y) :type ,(field-type sym))) + (t/store-set ,sym + (t/store-ref ,sym sto-x of-x) sto-y of-y) + (t/store-set ,sym + y-val sto-x of-x))) + ,y)))) ;;---------------------------------------------------------------;; -;;Generic function in src;base;generic-swap.lisp - (defmethod swap! :before ((x standard-tensor) (y standard-tensor)) - (assert (lvec-eq (dimensions x) (dimensions y) #'=) nil + (assert (very-quickly (lvec-eq (the index-store-vector (dimensions x)) (the index-store-vector (dimensions y)) #'=)) nil 'tensor-dimension-mismatch)) -(defmethod swap! ((x complex-tensor) (y real-tensor)) - (error 'coercion-error :from 'complex-tensor :to 'real-tensor)) - -(defmethod swap! ((x real-tensor) (y complex-tensor)) - (error 'coercion-error :from 'complex-tensor :to 'real-tensor)) - -(defmethod swap! ((x real-tensor) (y real-tensor)) - (real-typed-swap! x y)) - -(defmethod swap! ((x complex-tensor) (y complex-tensor)) - (complex-typed-swap! x y)) +(defmethod swap! ((x standard-tensor) (y standard-tensor)) + (let ((clx (class-name (class-of x))) + (cly (class-name (class-of y)))) + (assert (and (member clx *tensor-type-leaves*) + (member cly *tensor-type-leaves*)) + nil 'tensor-abstract-class :tensor-class (list clx cly)) + (if (eq clx cly) + (progn + (compile-and-eval + `(defmethod swap! ((x ,clx) (y ,cly)) + ,(recursive-append + (when (subtypep clx 'blas-numeric-tensor) + `(if-let (strd (and (call-fortran? x (t/l1-lb ,clx)) (blas-copyablep x y))) + (let ((sz (size x))) (t/blas-swap! ,clx sz x (first strd) y (second strd))))) + `(very-quickly (t/swap! ,clx x y))) + y)) + (swap! x y)) + ;;It is silly to swap a real vector with a complex one, no? + (error "Don't know how to swap ~a and ~a." clx cly)))) commit ecbc68d2926eb4dc1299401beb741e3551a3941d Author: Akshay Srinivasan <aks...@gm...> Date: Wed Jun 19 02:17:31 2013 -0700 Pushed all the templates definitions inside a eval-when form. diff --git a/src/utilities/template.lisp b/src/utilities/template.lisp index 24818e7..0392817 100644 --- a/src/utilities/template.lisp +++ b/src/utilities/template.lisp @@ -3,7 +3,8 @@ ;;Suck on that C++ :) (eval-when (:compile-toplevel :load-toplevel :execute) - (defvar *template-table* (make-hash-table))) + +(defvar *template-table* (make-hash-table)) (defun match-lambda-lists (lsta lstb) (let ((optional? nil)) @@ -100,3 +101,4 @@ (setf (getf data :methods) (setrem meth spls #'(lambda (a b) (list-eq (second a) b)))) nil)) +) ----------------------------------------------------------------------- Summary of changes: matlisp.asd | 8 +- packages.lisp | 2 +- src/base/loopy.lisp | 146 +++++++++++----------- src/base/print.lisp | 2 +- src/base/standard-tensor.lisp | 20 ++- src/base/template.lisp | 2 +- src/level-1/axpy.lisp | 273 ++++++++++++++--------------------------- src/level-1/copy.lisp | 152 +++++++++++------------- src/level-1/dot.lisp | 67 +++++------ src/level-1/maker.lisp | 15 ++- src/level-1/scal.lisp | 48 +++++++- src/level-1/swap.lisp | 118 +++++++++--------- src/utilities/macros.lisp | 5 + src/utilities/template.lisp | 6 +- 14 files changed, 403 insertions(+), 461 deletions(-) hooks/post-receive -- matlisp |
From: Akshay S. <ak...@us...> - 2013-06-19 09:14:41
|
This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "matlisp". The branch, classy has been updated via 50fcc688d2f72e751722b74e994808ad90f4c1ce (commit) via c108b24c014b002d9d0465ed895a8223a766230a (commit) via 0b071d4d11400da962b99cbff50ee42afc443b0b (commit) via ca0287f4334829367de787ba0e20947f53b6298c (commit) via 24def88c5b5227b29154cee9e05d88d119ceade8 (commit) via ba36a2d0877b66fc5b6b4055b9310b2e60a54186 (commit) via c213febdfa60e0b1a9a11c796911eb5b93fef90e (commit) from ea151122023fbd5d481a831645292fa3232b7b8b (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 50fcc688d2f72e751722b74e994808ad90f4c1ce Author: Akshay Srinivasan <aks...@gm...> Date: Wed Jun 19 02:07:37 2013 -0700 Cleanup. diff --git a/matlisp.asd b/matlisp.asd index 6a36308..1526b85 100644 --- a/matlisp.asd +++ b/matlisp.asd @@ -134,19 +134,18 @@ (:module "matlisp-level-1" :pathname "level-1" :depends-on ("matlisp-base" "matlisp-classes" "foreign-core") - :components ((:file "tensor-maker") + :components ((:file "maker") + (:file "copy" + :depends-on ("maker")) + (:file "dot" + :depends-on ("maker")) #+nil ( (:file "swap") - - (:file "copy" - :depends-on ("tensor-maker")) (:file "realimag" :depends-on ("copy")) (:file "scal" :depends-on ("copy" "tensor-maker" "realimag")) - (:file "dot" - :depends-on ("realimag")) (:file "axpy" :depends-on ("copy" "scal")) (:file "trans" diff --git a/src/level-1/tensor-maker.lisp b/src/level-1/maker.lisp similarity index 100% rename from src/level-1/tensor-maker.lisp rename to src/level-1/maker.lisp commit c108b24c014b002d9d0465ed895a8223a766230a Author: Akshay Srinivasan <aks...@gm...> Date: Wed Jun 19 02:05:50 2013 -0700 Migrated dot, copy to the new system. diff --git a/src/base/blas-helpers.lisp b/src/base/blas-helpers.lisp index 6b8b735..11ef0c0 100644 --- a/src/base/blas-helpers.lisp +++ b/src/base/blas-helpers.lisp @@ -77,6 +77,6 @@ (defun make-stride (dims) (ecase *default-stride-ordering* (:row-major (make-stride-rmj dims)) (:col-major (make-stride-cmj dims)))) -(definline call-fortran? (x lb) +(defun call-fortran? (x lb) (declare (type standard-tensor x)) - (> (lvec-max (the index-store-vector (dimensions x))) lb)) + (> (size x) lb)) diff --git a/src/base/generic-copy.lisp b/src/base/generic-copy.lisp index 128d66c..543fa5c 100644 --- a/src/base/generic-copy.lisp +++ b/src/base/generic-copy.lisp @@ -90,6 +90,9 @@ ======= Return a copy of X")) +(defmethod copy ((num number)) + num) + (defmethod copy ((lst cons)) (copy-list lst)) diff --git a/src/base/tweakable.lisp b/src/base/tweakable.lisp index 02f7e00..3ad44fc 100644 --- a/src/base/tweakable.lisp +++ b/src/base/tweakable.lisp @@ -27,13 +27,13 @@ ") ;;Level 1--------------------------------------------------------;; -(defparameter *real-l1-fcall-lb* 20000 +(defparameter *real-l1-fcall-lb* 50000 "If the size of the array is less than this parameter, the lisp version of axpy is called in order to avoid FFI overheads. The Fortran function is not called if the tensor does not have a consecutive store (see blas-helpers.lisp/consecutive-store-p).") -(defparameter *complex-l1-fcall-lb* 10000 +(defparameter *complex-l1-fcall-lb* 20000 "If the size of the array is less than this parameter, the lisp version of axpy is called in order to avoid FFI overheads. The Fortran function is not called if the tensor does not have diff --git a/src/level-1/copy.lisp b/src/level-1/copy.lisp index e67612d..0800470 100644 --- a/src/level-1/copy.lisp +++ b/src/level-1/copy.lisp @@ -136,24 +136,6 @@ (assert (very-quickly (lvec-eq (the index-store-vector (dimensions x)) (the index-store-vector (dimensions y)) #'=)) nil 'tensor-dimension-mismatch)) -;;This shouldn't happen ideally -(defmethod copy! ((x t) (y standard-tensor)) - (let ((clname (class-name (class-of y)))) - (assert (member clname *tensor-type-leaves*) nil 'tensor-abstract-class :tensor-class clname) - (warn "copy! method being generated for '(t ~a), does not use BLAS." clname) - (compile-and-eval - `(defmethod copy! ((x t) (y ,clname)) - (let-typed ((sto-y (store y) :type (simple-array ,(store-element-type clname))) - (cx (t/coerce ,(field-type clname) x) :type ,(field-type clname))) - ;;This should be safe - (very-quickly - (mod-dotimes (idx (dimensions y)) - :with (linear-sums - (of-y (strides y) (head y))) - :do (t/store-set ,clname cx sto-y of-y)))) - y)) - (copy! x y))) - (defmethod copy! ((x standard-tensor) (y standard-tensor)) (let ((clx (class-name (class-of x))) (cly (class-name (class-of y)))) @@ -166,142 +148,30 @@ `(defmethod copy! ((x ,clx) (y ,cly)) ,(recursive-append (when (subtypep clx 'blas-numeric-tensor) - `(if (and (call-fortran? x (t/l1-lb ,clx)) (blas-copyable-p - - (mod-dotimes (idx (dimensions x)) - do (setf (tensor-ref y idx) (tensor-ref x idx))) - y) - -(defmethod copy! ((x complex-tensor) (y real-tensor)) - (error 'coercion-error :from 'complex-tensor :to 'real-tensor)) - -(defmethod copy! ((x real-tensor) (y real-tensor)) - (real-typed-copy! x y)) - -(defmethod copy! ((x number) (y real-tensor)) - (real-typed-num-copy! (coerce-real x) y)) - -(defmethod copy! ((x complex-tensor) (y complex-tensor)) - (complex-typed-copy! x y)) - -(defmethod copy! ((x real-tensor) (y complex-tensor)) - ;;Borrowed from realimag.lisp - (let ((tmp (make-instance 'real-tensor - :parent-tensor y :store (store y) - :dimensions (dimensions y) - :strides (map 'index-store-vector #'(lambda (n) (* 2 n)) (strides y)) - :head (the index-type (* 2 (head y)))))) - (declare (type real-tensor tmp)) - (real-typed-copy! x tmp) - ;;Increasing the head by 1 points us to the imaginary part. - (incf (head tmp)) - (real-typed-num-copy! 0d0 tmp)) - y) - -(defmethod copy! ((x number) (y complex-tensor)) - (complex-typed-num-copy! (coerce-complex x) y)) - -;; Copy between a Lisp array and a tensor -(defun convert-to-lisp-array (tensor) - " - Syntax - ====== - (convert-to-lisp-array tensor) - - Purpose - ======= - Create a new Lisp array with the same dimensions as the tensor and - with the same elements. This is a copy of the tensor. -" - (declare (type standard-tensor tensor)) - (let*-typed ((dims (dimensions tensor) :type index-store-vector) - (ret (make-array (lvec->list dims) - :element-type (or (getf (get-tensor-object-optimization tensor) :element-type) - (error 'tensor-cannot-find-optimization :tensor-class (class-name (class-of tensor))))))) - (let ((lst (make-list (rank tensor)))) - (very-quickly - (mod-dotimes (idx dims) - do (setf (apply #'aref ret (lvec->list! idx lst)) (tensor-ref tensor idx)))) - ret))) - -(defmethod copy! :before ((x standard-tensor) (y array)) - (assert (subtypep (getf (get-tensor-object-optimization x) :element-type) - (array-element-type y)) - nil 'invalid-type - :given (getf (get-tensor-object-optimization x) :element-type) - :expected (array-element-type y)) - (assert (and - (= (rank x) (array-rank y)) - (dolist (ele (mapcar #'= (lvec->list (dimensions x)) (array-dimensions y)) t) - (unless ele (return nil)))) - nil 'dimension-mismatch)) - -(defmethod copy! ((x real-tensor) (y array)) - (let-typed ((sto-x (store x) :type real-store-vector) - (lst (make-list (rank x)) :type cons)) - (mod-dotimes (idx (dimensions x)) - with (linear-sums - (of-x (strides x) (head x))) - do (setf (apply #'aref y (lvec->list! idx lst)) - (aref sto-x of-x)))) - y) - -(defmethod copy! ((x complex-tensor) (y array)) - (let-typed ((sto-x (store x) :type complex-store-vector) - (lst (make-list (rank x)) :type cons)) - (mod-dotimes (idx (dimensions x)) - with (linear-sums - (of-x (strides x) (head x))) - do (setf (apply #'aref y (lvec->list! idx lst)) - (complex (aref sto-x (* 2 of-x)) (aref sto-x (1+ (* 2 of-x))))))) - y) - -;; -(defmethod copy! :before ((x array) (y standard-tensor)) - (assert (subtypep (array-element-type x) - (getf (get-tensor-object-optimization y) :element-type)) - nil 'invalid-type - :given (array-element-type x) :expected (getf (get-tensor-object-optimization y) :element-type)) - (assert (and - (= (array-rank x) (rank y)) - (dolist (ele (mapcar #'= (array-dimensions x) (lvec->list (dimensions y))) t) - (unless ele (return nil)))) - nil 'dimension-mismatch)) - -(defmethod copy! ((x array) (y real-tensor)) - (let-typed ((sto-y (store y) :type real-store-vector) - (lst (make-list (array-rank x)) :type cons)) - (very-quickly - (mod-dotimes (idx (dimensions y)) - with (linear-sums - (of-y (strides y) (head y))) - do (setf (aref sto-y of-y) (apply #'aref x (lvec->list! idx lst)))))) - y) + `(if-let (strd (and (call-fortran? x (t/l1-lb ,clx)) (blas-copyablep x y))) + (let ((sz (size x))) (t/blas-copy! ,clx sz x (first strd) y (second strd))))) + `(very-quickly (t/copy! (,clx ,cly) x y))) + y))) + (compile-and-eval + `(defmethod copy! ((x ,clx) (y ,cly)) + (t/copy! (,clx ,cly) x y) + y))) + (copy! x y))) -(defmethod copy! ((x array) (y complex-tensor)) - (let-typed ((sto-y (store y) :type real-store-vector) - (lst (make-list (array-rank x)) :type cons)) - (very-quickly - (mod-dotimes (idx (dimensions y)) - with (linear-sums - (of-y (strides y) (head y))) - do (let-typed ((ele (apply #'aref x (lvec->list! idx lst)) :type complex-type)) - (setf (aref sto-y (* 2 of-y)) (realpart ele) - (aref sto-y (1+ (* 2 of-y))) (imagpart ele)))))) - y) +(defmethod copy! ((x t) (y standard-tensor)) + (let ((cly (class-name (class-of y)))) + (assert (and (member cly *tensor-type-leaves*)) + nil 'tensor-abstract-class :tensor-class cly) + (compile-and-eval + `(defmethod copy! ((x t) (y ,cly)) + ,(recursive-append + (when (subtypep cly 'blas-numeric-tensor) + `(if-let (strd (and (call-fortran? y (t/l1-lb ,cly)) (consecutive-storep y))) + (let ((sz (size y))) (t/blas-num-copy! ,cly sz x y strd)))) + `(very-quickly (t/copy! (t ,cly) x y))))) + (copy! x y))) -;; ;;Generic function defined in src;base;generic-copy.lisp - -(defmethod copy ((tensor real-tensor)) - (let* ((ret (apply #'make-real-tensor (lvec->list (dimensions tensor))))) - (declare (type real-tensor ret)) +(defmethod copy ((tensor standard-tensor)) + (let* ((ret (zeros (the index-store-vector (dimensions tensor)) (class-name (class-of tensor))))) (copy! tensor ret))) - -(defmethod copy ((tensor complex-tensor)) - (let* ((ret (apply #'make-complex-tensor (lvec->list (dimensions tensor))))) - (declare (type complex-tensor ret)) - (copy! tensor ret))) - -(defmethod copy ((tensor number)) - tensor) diff --git a/src/level-1/dot.lisp b/src/level-1/dot.lisp index dc26862..a7ac53e 100644 --- a/src/level-1/dot.lisp +++ b/src/level-1/dot.lisp @@ -105,7 +105,7 @@ ") (:method :before ((x standard-tensor) (y standard-tensor) &optional (conjugate-p t)) (declare (ignore conjugate-p)) - (unless (and (vector-p x) (vector-p y) (very-quickly (lvec-eq (the index-store-vector (dimensions x)) (the index-store-vector (dimensions y)) #'=))) + (unless (and (tensor-vectorp x) (tensor-vectorp y) (= (aref (the index-store-vector (dimensions x)) 0) (aref (the index-store-vector (dimensions y)) 0))) (error 'tensor-dimension-mismatch)))) (defmethod dot ((x number) (y number) &optional (conjugate-p t)) @@ -119,24 +119,26 @@ (assert (and (member clx *tensor-type-leaves*) (member cly *tensor-type-leaves*)) nil 'tensor-abstract-class :tensor-class (list clx cly)) - (if (eq clx cly) - (progn - (compile-and-eval - `(defmethod dot ((x ,clx) (y ,cly) &optional (conjugate-p t)) - ,(recursive-append - (when (subtypep clx 'blas-numeric-tensor) - `(if (call-fortran? x (t/l1-lb ,clx)) - (if conjugate-p - (t/blas-dot ,clx x y t) - (t/blas-dot ,clx x y nil)))) - `(if conjugate-p - ;;Please do your checks before coming here. - (very-quickly (t/dot ,clx x y t)) - (very-quickly (t/dot ,clx x y nil)))))) - (dot x y conjugate-p)) - ;;You pay the piper if you like mixing types. - ;;This is (or should be) a rare enough to not matter. - (or (handler-case - (dot (copy! x (zeros (dimensions x) cly)) y conjugate-p) - (error () nil)) - (dot x (copy! y (zeros (dimensions y) clx)) conjugate-p))))) + (cond + ((eq clx cly) + (compile-and-eval + `(defmethod dot ((x ,clx) (y ,cly) &optional (conjugate-p t)) + ,(recursive-append + (when (subtypep clx 'blas-numeric-tensor) + `(if (call-fortran? x (t/l1-lb ,clx)) + (if conjugate-p + (t/blas-dot ,clx x y t) + (t/blas-dot ,clx x y nil)))) + `(if conjugate-p + ;;Please do your checks before coming here. + (very-quickly (t/dot ,clx x y t)) + (very-quickly (t/dot ,clx x y nil)))))) + (dot x y conjugate-p)) + ;;You pay the piper if you like mixing types. + ;;This is (or should be) a rare enough to not matter. + ((coerceable? clx cly) + (dot (copy! x (zeros (dimensions x) cly)) y conjugate-p)) + ((coerceable? cly clx) + (dot x (copy! y (zeros (dimensions y) clx)) conjugate-p)) + (t + (error "Don't know how to compute the dot product of ~a , ~a." clx cly))))) commit 0b071d4d11400da962b99cbff50ee42afc443b0b Author: Akshay Srinivasan <aks...@gm...> Date: Wed Jun 19 01:28:54 2013 -0700 Cleaned up blas-helpers.lisp diff --git a/matlisp.asd b/matlisp.asd index 9c1efa3..6a36308 100644 --- a/matlisp.asd +++ b/matlisp.asd @@ -128,6 +128,7 @@ :components ((:file "numeric") #+maxima (:file "symbolic-tensor") + #+nil (:file "matrix" :depends-on ("numeric")))) (:module "matlisp-level-1" diff --git a/packages.lisp b/packages.lisp index 96949cb..4168ed9 100644 --- a/packages.lisp +++ b/packages.lisp @@ -32,34 +32,34 @@ (:export ;;<conditon {accessors*}> ;;Generic errors - #:generic-error #:message + #:generic-error #:dimension-mismatch #:assumption-violated - #:invalid-type #:given #:expected - #:invalid-arguments #:argnum - #:invalid-value #:given #:expected - #:unknown-token #:token + #:invalid-type + #:invalid-arguments + #:invalid-value + #:unknown-token #:parser-error - #:coercion-error #:from #:to - #:out-of-bounds-error #:requested #:bound - #:non-uniform-bounds-error #:assumed #:found + #:coercion-error + #:out-of-bounds-error + #:non-uniform-bounds-error ;;Permutation conditions - #:permutation #:permutation + #:permutation #:permutation-invalid-error - #:permutation-permute-error #:seq-len #:group-rank + #:permutation-permute-error ;;Tensor conditions - #:tensor-error #:tensor - #:tensor-store-index-out-of-bounds #:index #:store-size - #:tensor-insufficient-store #:store-size #:max-idx - #:tensor-not-matrix #:rank - #:tensor-not-vector #:rank - #:tensor-index-out-of-bounds #:argument #:index #:dimension - #:tensor-index-rank-mismatch #:index-rank #:rank - #:tensor-invalid-head-value #:head - #:tensor-invalid-dimension-value #:argument #:dimension - #:tensor-invalid-stride-value #:argument #:stride - #:tensor-cannot-find-counter-class #:tensor-class - #:tensor-cannot-find-optimization #:tensor-class + #:tensor-error + #:tensor-store-index-out-of-bounds + #:tensor-insufficient-store + #:tensor-not-matrix + #:tensor-not-vector + #:tensor-index-out-of-bounds + #:tensor-index-rank-mismatch + #:tensor-invalid-head-value + #:tensor-invalid-dimension-value + #:tensor-invalid-stride-value + #:tensor-cannot-find-counter-class + #:tensor-cannot-find-optimization #:tensor-dimension-mismatch #:tensor-store-not-consecutive #:tensor-method-does-not-exist diff --git a/src/base/blas-helpers.lisp b/src/base/blas-helpers.lisp index 07664c2..6b8b735 100644 --- a/src/base/blas-helpers.lisp +++ b/src/base/blas-helpers.lisp @@ -1,12 +1,35 @@ (in-package #:matlisp) + +(defun consecutive-storep (tensor) + (declare (type standard-tensor tensor)) + (memoizing (tensor consecutive-storep) + (mlet* (((sort-std std-perm) (very-quickly (sort-permute-base (copy-seq (the index-store-vector (strides tensor))) #'<)) + :type (index-store-vector pindex-store-vector)) + (perm-dims (very-quickly (apply-action! (copy-seq (the index-store-vector (dimensions tensor))) std-perm)) :type index-store-vector)) + (very-quickly + (loop + :for so-st :across sort-std + :for so-di :across perm-dims + :and accumulated-off := (aref sort-std 0) :then (the index-type (* accumulated-off so-di)) + :unless (= so-st accumulated-off) :do (return (values nil perm-dims sort-std std-perm)) + :finally (return (values (aref sort-std 0) perm-dims sort-std std-perm))))))) + +(defun blas-copyablep (ten-a ten-b) + (declare (type standard-tensor ten-a ten-b)) + (when (= (rank ten-a) (rank ten-b)) + (mlet* + (((csto-a? pdims-a tmp perm-a) (consecutive-storep ten-a) :type (t index-store-vector nil pindex-store-vector)) + ((csto-b? pdims-b tmp perm-b) (consecutive-storep ten-b) :type (t index-store-vector nil pindex-store-vector))) + (when (and csto-a? csto-b? (very-quickly (lvec-eq perm-a perm-b)) (very-quickly (lvec-eq pdims-a pdims-b))) + (list csto-a? csto-b?))))) (definline fortran-nop (op) - (ecase op (#\T #\N) (#\N #\T))) + (ecase op (#\t #\n) (#\n #\t))) (defun split-job (job) (declare (type symbol job)) (let-typed ((name (symbol-name job) :type string)) - (loop :for x :across name :collect x))) + (loop :for x :across name :collect (char-downcase x)))) (definline flip-major (job) (declare (type symbol job)) @@ -14,47 +37,10 @@ (:row-major :col-major) (:col-major :row-major))) -(defun blas-copyable-p (ten-a ten-b) - (declare (type standard-tensor ten-a ten-b)) - (when (= (rank ten-a) (rank ten-b)) - (mlet* - (((sort-std-a std-a-perm) (very-quickly (sort-permute-base (copy-seq (the index-store-vector (strides ten-a))) #'<)) :type (index-store-vector pindex-store-vector)) - (perm-a-dims (very-quickly (apply-action! (copy-seq (the index-store-vector (dimensions ten-a))) std-a-perm)) :type index-store-vector) - ;;If blas-copyable then the strides must have the same sorting permutation. - (sort-std-b (very-quickly (apply-action! (copy-seq (the index-store-vector (strides ten-b))) std-a-perm)) :type index-store-vector) - (perm-b-dims (very-quickly (apply-action! (copy-seq (the index-store-vector (dimensions ten-b))) std-a-perm)) :type index-store-vector)) - (very-quickly - (loop - :for i :of-type index-type :from 0 :below (rank ten-a) - :for sost-a :across sort-std-a - :for a-aoff :of-type index-type := (aref sort-std-a 0) :then (the index-type (* a-aoff (aref perm-a-dims (1- i)))) - ;; - :for sost-b :across sort-std-b - :for b-aoff :of-type index-type := (aref sort-std-b 0) :then (the index-type (* b-aoff (aref perm-b-dims (1- i)))) - ;; - :do (unless (and (= sost-a a-aoff) - (= sost-b b-aoff) - (= (aref perm-a-dims i) (aref perm-b-dims i))) - (return nil)) - :finally (return (list (aref sort-std-a 0) (aref sort-std-b 0)))))))) - -(definline consecutive-store-p (tensor) - (declare (type standard-tensor tensor)) - (mlet* (((sort-std std-perm) (very-quickly (sort-permute-base (copy-seq (the index-store-vector (strides tensor))) #'<)) - :type (index-store-vector pindex-store-vector)) - (perm-dims (very-quickly (apply-action! (copy-seq (the index-store-vector (dimensions tensor))) std-perm)) :type index-store-vector)) - (very-quickly - (loop - :for so-st :across sort-std - :for so-di :across perm-dims - :and accumulated-off := (aref sort-std 0) :then (the index-type (* accumulated-off so-di)) - :unless (= so-st accumulated-off) :do (return nil) - - :finally (return (values t (aref sort-std 0))))))) - -(definline blas-matrix-compatible-p (matrix op) - (declare (type standard-matrix matrix) +(definline blas-matrix-compatiblep (matrix op) + (declare (type standard-tensor matrix) (type character op)) + (assert (tensor-matrixp matrix) nil 'tensor-not-matrix) (let*-typed ((stds (strides matrix) :type index-store-vector) (rs (aref stds 0) :type index-type) (cs (aref stds 1) :type index-type)) diff --git a/src/base/permutation.lisp b/src/base/permutation.lisp index 5777efe..0869622 100644 --- a/src/base/permutation.lisp +++ b/src/base/permutation.lisp @@ -1,8 +1,10 @@ (in-package #:matlisp) ;;This must match the type used in LAPACK +;;(unsigned-byte 32) + (deftype pindex-type () - '(unsigned-byte 32)) + 'fixnum) (deftype pindex-store-vector (&optional (size '*)) `(simple-array pindex-type (,size))) diff --git a/src/base/standard-tensor.lisp b/src/base/standard-tensor.lisp index 397e8e7..0544757 100644 --- a/src/base/standard-tensor.lisp +++ b/src/base/standard-tensor.lisp @@ -62,6 +62,18 @@ :documentation "Place for computable attributes of an object instance.")) (:documentation "Basic tensor class.")) +(defmacro memoizing ((tensor name) &rest body) + (declare (type symbol name)) + (with-gensyms (tens) + `(let* ((,tens ,tensor)) + (declare (type standard-tensor ,tens)) + (multiple-value-bind (value present?) (gethash ',name (attributes ,tens)) + (values-list + (if present? + value + (setf (gethash ',name (attributes ,tens)) + (multiple-value-list (progn ,@body))))))))) + ;;I have no idea what this does, or why we want it (inherited from standard-matrix.lisp) (defmethod make-load-form ((tensor standard-tensor) &optional env) " @@ -69,30 +81,14 @@ tensor, for example #.(make-tensors ...)" (make-load-form-saving-slots tensor :environment env)) -;;These should ideally be memoised -(defgeneric rank (tensor) - (:documentation " - Syntax - ====== - (rank tensor) - - Purpose - ======= - Returns the rank of the tensor object.") - (:method ((tensor standard-tensor)) - (length (dimensions tensor)))) - -(defgeneric size (tensor) - (:documentation " - Syntax - ====== - (size tensor) +;;These should ideally be memoised (or not) +(definline rank (tensor) + (declare (type standard-tensor tensor)) + (length (the index-store-vector (dimensions tensor)))) - Purpose - ======= - Returns the number of elements in the tensor.") - (:method ((tensor standard-tensor)) - (lvec-foldr #'* (the index-store-vector (dimensions tensor))))) +(definline size (tensor) + (declare (type standard-tensor tensor)) + (lvec-foldr #'* (the index-store-vector (dimensions tensor)))) (defgeneric store-size (tensor) (:documentation " @@ -296,7 +292,7 @@ (setf (store-ref tensor idx) value))) ;; -(defun tensor-typep (tensor subscripts) +(defun tensor-typep (tensor subs) " Syntax ====== @@ -310,31 +306,35 @@ Examples ======== Checking for a vector: - > (tensor-typep ten '(*)) + > (tensor-typep ten '(class-name *)) Checking for a matrix with 2 columns: - > (tensor-typep ten '(* 2)) + > (tensor-typep ten '(real-tensor (* 2))) " (declare (type standard-tensor tensor)) - (let-typed ((rank (rank tensor) :type index-type) - (dims (dimensions tensor) :type index-store-vector)) - (very-quickly - (loop :for val :in subscripts - :for i :of-type index-type := 0 :then (1+ i) - :do (unless (or (eq val '*) (eq val (aref dims i))) - (return nil)) - :finally (return (when (= (1+ i) rank) t)))))) - -(definline matrix-p (ten) + (destructuring-bind (cls &optional subscripts) (ensure-list subs) + (and (typep tensor cls) + (if subscripts + (let-typed ((rank (rank tensor) :type index-type) + (dims (dimensions tensor) :type index-store-vector)) + (very-quickly + (loop :for val :in subscripts + :for i :of-type index-type := 0 :then (1+ i) + :do (unless (or (eq val '*) (eq val (aref dims i))) + (return nil)) + :finally (return (when (= (1+ i) rank) t))))) + t)))) + +(definline tensor-matrixp (ten) (declare (type standard-tensor ten)) (= (rank ten) 2)) -(definline vector-p (ten) +(definline tensor-vectorp (ten) (declare (type standard-tensor ten)) (= (rank ten) 1)) -(definline square-p (tensor) +(definline tensor-squarep (tensor) (let-typed ((dims (dimensions tensor) :type index-store-vector)) (lvec-foldr #'(lambda (a b) (if (eq a b) a nil)) dims))) @@ -357,13 +357,13 @@ X ;; Get (:, 0, 0) - > (sub-tensor~ X '((* * *) (0 * 1) (0 * 1))) + > (sub-tensor/ X '((* * *) (0 * 1) (0 * 1))) ;; Get (:, 2:5, :) - > (sub-tensor~ X '((* * *) (2 * 5))) + > (sub-tensor/ X '((* * *) (2 * 5))) ;; Get (:, :, 0:2:10) (0:10:2 = [i : 0 <= i < 10, i % 2 = 0]) - > (sub-tensor~ X '((* * *) (* * *) (0 2 10))) + > (sub-tensor/ X '((* * *) (* * *) (0 2 10))) Commentary ========== diff --git a/src/level-1/copy.lisp b/src/level-1/copy.lisp index c01039e..e67612d 100644 --- a/src/level-1/copy.lisp +++ b/src/level-1/copy.lisp @@ -133,7 +133,7 @@ ;; (defmethod copy! :before ((x standard-tensor) (y standard-tensor)) - (assert (lvec-eq (dimensions x) (dimensions y) #'=) nil + (assert (very-quickly (lvec-eq (the index-store-vector (dimensions x)) (the index-store-vector (dimensions y)) #'=)) nil 'tensor-dimension-mismatch)) ;;This shouldn't happen ideally @@ -166,7 +166,7 @@ `(defmethod copy! ((x ,clx) (y ,cly)) ,(recursive-append (when (subtypep clx 'blas-numeric-tensor) - + `(if (and (call-fortran? x (t/l1-lb ,clx)) (blas-copyable-p (mod-dotimes (idx (dimensions x)) do (setf (tensor-ref y idx) (tensor-ref x idx))) commit ca0287f4334829367de787ba0e20947f53b6298c Merge: ea15112 24def88 Author: Akshay Srinivasan <aks...@gm...> Date: Tue Jun 18 23:34:49 2013 -0700 Merge branch 'tensor' into classy Conflicts: matlisp.asd src/base/blas-helpers.lisp src/base/standard-tensor.lisp src/level-1/tensor-maker.lisp src/utilities/functions.lisp diff --cc matlisp.asd index 5b8b043,dc7a129..9c1efa3 --- a/matlisp.asd +++ b/matlisp.asd @@@ -122,14 -125,12 +125,11 @@@ (:module "matlisp-classes" :pathname "classes" :depends-on ("matlisp-base") - :components ((:file "real-tensor") - (:file "complex-tensor") + :components ((:file "numeric") #+maxima (:file "symbolic-tensor") - #+nil (:file "matrix" - :depends-on ("real-tensor" "complex-tensor")))) - #+nil + :depends-on ("numeric")))) (:module "matlisp-level-1" :pathname "level-1" :depends-on ("matlisp-base" "matlisp-classes" "foreign-core") @@@ -146,7 -150,7 +149,8 @@@ (:file "axpy" :depends-on ("copy" "scal")) (:file "trans" - :depends-on ("scal" "copy")))) + :depends-on ("scal" "copy"))))) ++ #+nil (:module "matlisp-level-2" :pathname "level-2" diff --cc src/base/blas-helpers.lisp index f48901a,e34dc8b..07664c2 --- a/src/base/blas-helpers.lisp +++ b/src/base/blas-helpers.lisp @@@ -1,60 -1,47 +1,60 @@@ (in-package #:matlisp) -;;Check dimensions of the tensors before passing the argument here! +(definline fortran-nop (op) + (ecase op (#\T #\N) (#\N #\T))) + +(defun split-job (job) + (declare (type symbol job)) + (let-typed ((name (symbol-name job) :type string)) + (loop :for x :across name :collect x))) + +(definline flip-major (job) + (declare (type symbol job)) + (case job + (:row-major :col-major) + (:col-major :row-major))) + (defun blas-copyable-p (ten-a ten-b) (declare (type standard-tensor ten-a ten-b)) - (mlet* - (((sort-std-a std-a-perm) (let-typed ((std-a (strides ten-a) :type index-store-vector)) - (very-quickly (sort-permute (copy-seq std-a) #'<))) - :type (index-store-vector permutation-action)) - (perm-a-dims (permute (dimensions ten-a) std-a-perm) :type index-store-vector) - ;;If blas-copyable then the strides must have the same sorting permutation. - (sort-std-b (permute (strides ten-b) std-a-perm) :type index-store-vector) - (perm-b-dims (permute (dimensions ten-b) std-a-perm) :type index-store-vector)) - (very-quickly - (loop - :for i :of-type index-type :from 0 :below (rank ten-a) - :for sost-a :across sort-std-a - :for a-aoff :of-type index-type := (aref sort-std-a 0) :then (the index-type (* a-aoff (aref perm-a-dims (1- i)))) - ;; - :for sost-b :across sort-std-b - :for b-aoff :of-type index-type := (aref sort-std-b 0) :then (the index-type (* b-aoff (aref perm-b-dims (1- i)))) - ;; - :do (progn - (unless (and (= sost-a a-aoff) - (= sost-b b-aoff)) - (return nil))) - :finally (return (list (aref sort-std-a 0) (aref sort-std-b 0))))))) + (when (= (rank ten-a) (rank ten-b)) + (mlet* + (((sort-std-a std-a-perm) (very-quickly (sort-permute-base (copy-seq (the index-store-vector (strides ten-a))) #'<)) :type (index-store-vector pindex-store-vector)) + (perm-a-dims (very-quickly (apply-action! (copy-seq (the index-store-vector (dimensions ten-a))) std-a-perm)) :type index-store-vector) + ;;If blas-copyable then the strides must have the same sorting permutation. + (sort-std-b (very-quickly (apply-action! (copy-seq (the index-store-vector (strides ten-b))) std-a-perm)) :type index-store-vector) + (perm-b-dims (very-quickly (apply-action! (copy-seq (the index-store-vector (dimensions ten-b))) std-a-perm)) :type index-store-vector)) + (very-quickly + (loop + :for i :of-type index-type :from 0 :below (rank ten-a) + :for sost-a :across sort-std-a + :for a-aoff :of-type index-type := (aref sort-std-a 0) :then (the index-type (* a-aoff (aref perm-a-dims (1- i)))) + ;; + :for sost-b :across sort-std-b + :for b-aoff :of-type index-type := (aref sort-std-b 0) :then (the index-type (* b-aoff (aref perm-b-dims (1- i)))) + ;; + :do (unless (and (= sost-a a-aoff) + (= sost-b b-aoff) + (= (aref perm-a-dims i) (aref perm-b-dims i))) + (return nil)) + :finally (return (list (aref sort-std-a 0) (aref sort-std-b 0)))))))) - (defmemo consecutive-store-p (tensor) -(defun consecutive-store-p (tensor) ++(definline consecutive-store-p (tensor) (declare (type standard-tensor tensor)) - (mlet* (((sort-std std-perm) (let-typed ((stds (strides tensor) :type index-store-vector)) - (very-quickly (sort-permute (copy-seq stds) #'<))) - :type (index-store-vector permutation)) - (perm-dims (permute (dimensions tensor) std-perm) :type index-store-vector)) - (very-quickly - (loop - :for so-st :across sort-std - :for so-di :across perm-dims - :and accumulated-off := (aref sort-std 0) :then (the index-type (* accumulated-off so-di)) - :unless (= so-st accumulated-off) :do (return nil) - :finally (return (aref sort-std 0)))))) + (mlet* (((sort-std std-perm) (very-quickly (sort-permute-base (copy-seq (the index-store-vector (strides tensor))) #'<)) + :type (index-store-vector pindex-store-vector)) + (perm-dims (very-quickly (apply-action! (copy-seq (the index-store-vector (dimensions tensor))) std-perm)) :type index-store-vector)) + (very-quickly + (loop + :for so-st :across sort-std + :for so-di :across perm-dims + :and accumulated-off := (aref sort-std 0) :then (the index-type (* accumulated-off so-di)) + :unless (= so-st accumulated-off) :do (return nil) + + :finally (return (values t (aref sort-std 0))))))) -(defun blas-matrix-compatible-p (matrix op) - (declare (type standard-tensor matrix)) +(definline blas-matrix-compatible-p (matrix op) + (declare (type standard-matrix matrix) + (type character op)) (let*-typed ((stds (strides matrix) :type index-store-vector) (rs (aref stds 0) :type index-type) (cs (aref stds 1) :type index-type)) diff --cc src/base/standard-tensor.lisp index 5e84180,d013aaf..397e8e7 --- a/src/base/standard-tensor.lisp +++ b/src/base/standard-tensor.lisp @@@ -14,7 -14,7 +14,7 @@@ (ALLOCATE-INDEX-STORE SIZE [INITIAL-ELEMENT 0]) Purpose -- ======= ++ ====== Allocates index storage.") (definline make-index-store (contents) @@@ -33,162 -33,87 +33,94 @@@ (make-index-store contents)) ;; - (defclass tensor () - ((dimensions - :reader dimensions - :initarg :dimensions - :type index-store-vector + (defvar *tensor-type-leaves* nil " + This is used to keep track of classes that are not meant to be + abstract classes. This prevents less specialized methods from + clobbering the generation of more sophisticated (read faster) + methods.") + + (defmacro defleaf (name direct-superclasses direct-slots &rest options) + `(progn + (defclass ,name ,direct-superclasses ,direct-slots ,@options) + (setf *tensor-type-leaves* (setadd *tensor-type-leaves* ',name)))) + + (defclass standard-tensor () + ((dimensions :reader dimensions :initarg :dimensions :type index-store-vector :documentation "Dimensions of the vector spaces in which the tensor's arguments reside.") ;; - (parent-tensor - :reader parent-tensor - :initarg :parent-tensor - :type tensor + (parent-tensor :reader parent-tensor :initarg :parent-tensor :type standard-tensor :documentation "If the tensor is a view of another tensor, then this slot is bound.") ;; - (store - :reader store - :initarg :store) + (head :initarg :head :initform 0 :reader head :type index-type + :documentation "Head for the store's accessor.") + (strides :initarg :strides :reader strides :type index-store-vector + :documentation "Strides for accesing elements of the tensor.") + (store :initarg :store :reader store + :documentation "The actual storage for the tensor.") ;; - (memos - :reader memos - :initarg :memos - :documentation "Cache for arbitrary (computable) attributes of the object."))) + (attributes :initarg :attributes :reader attributes :initform (make-hash-table) + :documentation "Place for computable attributes of an object instance.")) + (:documentation "Basic tensor class.")) - ;; - (defclass dense-tensor (tensor) - ((store :type dense-store))) ++;;I have no idea what this does, or why we want it (inherited from standard-matrix.lisp) ++(defmethod make-load-form ((tensor standard-tensor) &optional env) ++ " ++ MAKE-LOAD-FORM allows us to determine a load time value for ++ tensor, for example #.(make-tensors ...)" ++ (make-load-form-saving-slots tensor :environment env)) + - (defclass dense-store () - ((vector-store) - (head) - (strides)) + ;;These should ideally be memoised + (defgeneric rank (tensor) + (:documentation " + Syntax + ====== + (rank tensor) - ;; - (defclass standard-matrix (standard-tensor) - ((rank - :allocation :class - :initform 2 - :documentation "For a matrix, rank = 2.")) - (:documentation "Basic matrix class.")) - - (defmethod initialize-instance :after ((matrix standard-matrix) &rest initargs) - (declare (ignore initargs)) - (assert (= (rank matrix) 2) nil 'tensor-not-matrix :rank (rank matrix) :tensor matrix)) + Purpose + ======= + Returns the rank of the tensor object.") + (:method ((tensor standard-tensor)) + (length (dimensions tensor)))) - (defmethod update-instance-for-different-class :before ((old standard-tensor) (new standard-matrix) &rest initargs) - (declare (ignore initargs)) - (assert (= (rank old) 2) nil 'tensor-not-matrix :rank (rank old))) + (defgeneric size (tensor) + (:documentation " + Syntax + ====== + (size tensor) - ;; - (defclass standard-vector (standard-tensor) - ((rank - :allocation :class - :initform 1 - :documentation "For a vector, rank = 1.")) - (:documentation "Basic vector class.")) - - (defmethod initialize-instance :after ((vector standard-vector) &rest initargs) - (declare (ignore initargs)) - (assert (= (rank vector) 1) nil 'tensor-not-vector :rank (rank vector) :tensor vector)) + Purpose + ======= + Returns the number of elements in the tensor.") + (:method ((tensor standard-tensor)) + (lvec-foldr #'* (the index-store-vector (dimensions tensor))))) - (defmethod update-instance-for-different-class :before ((old standard-tensor) (new standard-vector) &rest initargs) - (declare (ignore initargs)) - (assert (= (rank old) 1) nil 'tensor-not-vector :rank (rank old))) + (defgeneric store-size (tensor) + (:documentation " + Syntax + ====== + (store-size tensor) - ;;Use - (defmacro defmemo (func-name (tensor) &rest body) - " - This macro defines a function taking a tensor argument @arg{tensor}, and memoizes the - results of the code @arg{body}. It is assumed that the function definition is functional - in character. - - Examples: - @lisp - > (macroexpand-1 `(defmemo thing (x) (+ x (rank x)))) - > (defun thing (x) - (declare (type standard-tensor x)) - (let ((memo-hash (memos x))) - (multiple-value-bind (value present?) (gethash 'thing memo-hash) - (if present? value - (let ((value (progn (+ x (rank x))))) - (setf (gethash 'thing memo-hash) value) - value))))) - T - > - @end lisp - " - (let ((decls (when (and (consp (car body)) (eql (caar body) 'declare)) (cdar body)))) - `(defun ,func-name (,tensor) - (declare (type standard-tensor ,tensor) - ,@decls) - (let* ((memo-hash (memos ,tensor))) - (multiple-value-bind (value present?) (gethash ',func-name memo-hash) - (if present? (values-list value) - (let ((value (multiple-value-list (progn ,@(if decls (cdr body) body))))) - (values-list (setf (gethash ',func-name memo-hash) value))))))))) - + Purpose + ======= + Returns the number of elements the store of the tensor can hold + (which is not necessarily equal to its vector length).") + (:method ((tensor standard-tensor)) + (length (store tensor)))) - ;; - (defvar *tensor-class-optimizations* (make-hash-table) - " - Contains a either: - o A property list containing: - :field-type -> Field type - :f+ (a b) -> a + b - :f- (a b) -> a + (- b) - :finv+ (a) -> -a - :fid+ () -> + identity - :f* (a b) -> a * b - :f/ (a b) -> a * b^{-1} - :finv* (a) -> 1/a - :fid* () -> * identity - :f= (a b) -> (= a b) - :fconj (a) -> a^* {if nil, Field does not have a conjugation op} - - :coercer (ele) -> Coerced to store-type, with error checking - :coercer-unforgiving (ele) -> Coerced to store-type, no error checking - - :store-allocator (n) -> Allocates a store of size n - :store-type - :reader (store idx) => result - :value-writer (value store idx) => (store idx) <- value - :reader-writer (fstore fidx tstore tidx) => (tstore tidx) <- (fstore fidx) - :swapper (fstore fidx tstore tidx) => (tstore tidx) <-> (fstore fidx) - o class-name (symbol) of the superclass whose optimizations - are to be made use of.") - - (definline get-tensor-class-optimization (clname) - (declare (type symbol clname)) - (symbol-plist clname)) - - (definline get-tensor-object-optimization (obj) - (symbol-plist (class-name (class-of obj)))) - - (defun get-tensor-class-optimization-hashtable (clname) - (let ((opt (gethash clname *tensor-class-optimizations*))) - (cond - ((null opt) nil) - ((symbolp opt) - (get-tensor-class-optimization opt)) - (t (values opt clname))))) - - (defun (setf get-tensor-class-optimization) (value clname) - (setf (gethash clname *tensor-class-optimizations*) value) - (let ((opt (if (symbolp value) - (get-tensor-class-optimization-hashtable clname) - value))) - (setf (symbol-plist (getf opt :tensor)) opt - (symbol-plist (getf opt :matrix)) opt - (symbol-plist (getf opt :vector)) opt))) - - ;; Akshay: I have no idea what this does, or why we want it - ;; (inherited from standard-matrix.lisp - (defmethod make-load-form ((tensor standard-tensor) &optional env) - " - MAKE-LOAD-FORM allows us to determine a load time value for - tensor, for example #.(make-tensors ...)" - (make-load-form-saving-slots tensor :environment env)) + (defgeneric print-element (tensor + element stream) + (:documentation " + Syntax + ====== + (PRINT-ELEMENT tensor element stream) + + Purpose + ======= + This generic function is specialized to TENSOR to + print ELEMENT to STREAM. Called by PRINT-TENSOR/MATRIX + to format a tensor into the STREAM.") + (:method ((tensor standard-tensor) element stream) + (format stream "~a" element))) ;; (defun store-indexing-vec (idx hd strides dims) @@@ -323,104 -246,47 +253,48 @@@ /_ i i i = 0 - of the store.")) - - (defgeneric (setf tensor-ref) (value tensor &rest subscripts)) - - ;; - (defgeneric tensor-store-ref (tensor store-idx) - (:documentation " - Syntax - ====== - (tensor-store-ref store store-idx) - - Purpose - ======= - Return the element store-idx of the tensor store.")) - - (defgeneric (setf tensor-store-ref) (value tensor idx)) - - ;; - (defgeneric print-element (tensor element stream) - (:documentation " - Syntax - ====== - (PRINT-ELEMENT tensor element stream) - - Purpose - ======= - This generic function is specialized to TENSOR to - print ELEMENT to STREAM. Called by PRINT-TENSOR/MATRIX - to format a tensor into the STREAM.") - (:method (tensor element stream) - (format stream "~a" element))) - - ;; - (defmacro define-tensor - ((tensor-class element-type store-element-type store-type &rest class-decls) &key - f+ f- finv+ fid+ f* f/ finv* fid* fconj f= - matrix vector - store-allocator coercer coercer-unforgiving reader value-writer value-incfer reader-writer swapper) - ;;Error checking - (assert (and f+ f- finv+ fid+ f* f/ finv* fid* f= store-allocator coercer coercer-unforgiving matrix vector reader value-writer value-incfer reader-writer swapper)) - ;; - `(progn - ;;Class definitions - (defclass ,tensor-class (standard-tensor) - ((store :type ,store-type)) - ,@class-decls) - (defclass ,matrix (standard-matrix ,tensor-class) - ()) - (defclass ,vector (standard-vector ,tensor-class) - ()) - ;;Store refs - (defmethod tensor-ref ((tensor ,tensor-class) &rest subs) - (let-typed ((lidx (store-indexing (if (typep (car subs) '(or cons vector)) (car subs) subs) tensor) :type index-type) - (sto-x (store tensor) :type ,(linear-array-type store-element-type))) - (,reader sto-x lidx))) - (defmethod (setf tensor-ref) (value (tensor ,tensor-class) &rest subs) - (let-typed ((lidx (store-indexing (if (typep (car subs) '(or cons vector)) (car subs) subs) tensor) :type index-type) - (sto-x (store tensor) :type ,(linear-array-type store-element-type))) - (,value-writer (,coercer-unforgiving value) sto-x lidx))) - (defmethod tensor-store-ref ((tensor ,tensor-class) lidx) - (declare (type index-type lidx)) - (let-typed ((sto-x (store tensor) :type ,(linear-array-type store-element-type))) - (,reader sto-x lidx))) - (defmethod (setf tensor-store-ref) (value (tensor ,tensor-class) lidx) - (declare (type index-type lidx)) - (let-typed ((sto-x (store tensor) :type ,(linear-array-type store-element-type))) - (,value-writer (,coercer-unforgiving value) sto-x lidx))) - ;; - (eval-when (:compile-toplevel :load-toplevel :execute) - (let ((hst (list - :tensor ',tensor-class - :matrix ',matrix - :vector ',vector - :element-type ',element-type - :f+ ',f+ - :f- ',f- - :finv+ ',finv+ - :fid+ ',fid+ - :f* ',f* - :f/ ',f/ - :finv* ',finv* - :fid* ',fid* - :f= ',f= - :fconj ',fconj - :reader ',reader - :value-writer ',value-writer - :value-incfer ',value-incfer - :reader-writer ',reader-writer - :swapper ',swapper - :store-allocator ',store-allocator - :coercer ',coercer - :coercer-unforgiving ',coercer-unforgiving - :store-type ',store-element-type))) - (setf (get-tensor-class-optimization ',tensor-class) hst - (get-tensor-class-optimization ',matrix) ',tensor-class - (get-tensor-class-optimization ',vector) ',tensor-class) - (setf (symbol-plist ',tensor-class) hst))))) + of the store.") + (:method ((tensor standard-tensor) &rest subscripts) + (let ((clname (class-name (class-of tensor)))) + (assert (member clname *tensor-type-leaves*) nil 'tensor-abstract-class :tensor-class clname) + (compile-and-eval + `(defmethod ref ((tensor ,clname) &rest subscripts) + (let ((subs (if (numberp (car subscripts)) subscripts (car subscripts)))) + (t/store-ref ,clname (store tensor) (store-indexing subs tensor))))) + (apply #'ref (cons tensor subscripts))))) + + (defgeneric (setf ref) (value tensor &rest subscripts) + (:method (value (tensor standard-tensor) &rest subscripts) + (let ((clname (class-name (class-of tensor)))) + (assert (member clname *tensor-type-leaves*) nil 'tensor-abstract-class :tensor-class clname) + (compile-and-eval + `(defmethod (setf ref) (value (tensor ,clname) &rest subscripts) + (let* ((subs (if (numberp (car subscripts)) subscripts (car subscripts))) + (idx (store-indexing subs tensor))) + (t/store-set ,clname value (store tensor) idx) + (t/store-ref ,clname (store tensor) idx)))) + (setf (apply #'ref (cons tensor subscripts)) value)))) + + (defgeneric store-ref (tensor idx) + (:documentation "Generic serial read access to the store.") + (:method ((tensor standard-tensor) idx) + (let ((clname (class-name (class-of tensor)))) + (assert (member clname *tensor-type-leaves*) nil 'tensor-abstract-class :tensor-class clname) + (compile-and-eval + `(defmethod store-ref ((tensor ,clname) idx) + (t/store-ref ,clname (store tensor) idx)))) + (store-ref tensor idx))) + + (defgeneric (setf store-ref) (value tensor idx) + (:method (value (tensor standard-tensor) idx) + (let ((clname (class-name (class-of tensor)))) + (assert (member clname *tensor-type-leaves*) nil 'tensor-abstract-class :tensor-class clname) + (compile-and-eval + `(defmethod (setf store-ref) (value (tensor ,clname) idx) + (t/store-set ,clname value (store tensor) idx) + (t/store-ref ,clname (store tensor) idx)))) + (setf (store-ref tensor idx) value))) + ;; (defun tensor-typep (tensor subscripts) " diff --cc src/level-1/tensor-maker.lisp index 700f8a5,2f1b409..21959a8 --- a/src/level-1/tensor-maker.lisp +++ b/src/level-1/tensor-maker.lisp @@@ -1,93 -1,30 +1,31 @@@ (in-package #:matlisp) - (defmacro make-tensor-maker (func-name (tensor-class)) - (let ((opt (get-tensor-class-optimization-hashtable tensor-class))) - (assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class) - `(progn - (eval-when (:compile-toplevel :load-toplevel :execute) - (let ((opt (get-tensor-class-optimization-hashtable ',tensor-class))) - (assert opt nil 'tensor-cannot-find-optimization :tensor-class ',tensor-class) - (setf (getf opt :maker) ',func-name - (get-tensor-class-optimization ',tensor-class) opt))) - (defun ,func-name (&rest args) - (labels ((make-dims (dims) - (declare (type cons dims)) - (let*-typed ((vdim (make-index-store dims) :type index-store-vector) - (ss (very-quickly (lvec-foldl #'(lambda (x y) (the index-type (* x y))) vdim))) - (store (,(getf opt :store-allocator) ss)) - (rnk (length vdim)) - (ret (let ((*check-after-initializing?* nil)) - (make-instance (case rnk (2 ',(getf opt :matrix)) (1 ',(getf opt :vector)) (t ',tensor-class)) - :rank rnk - :strides (make-stride vdim) - :store store :store-size ss :dimensions vdim)))) - (setf (slot-value ret 'number-of-elements) ss) - ret)) - (make-from-array (arr) - (declare (type (array * *) arr)) - (let* ((ret (make-dims (array-dimensions arr))) - (st-r (store ret)) - (lst (make-list (rank ret)))) - (declare (type ,tensor-class ret) - (type ,(linear-array-type (getf opt :store-type)) st-r)) - (mod-dotimes (idx (dimensions ret)) - with (linear-sums - (of-r (strides ret) (head ret))) - do (,(getf opt :value-writer) (,(getf opt :coercer) (apply #'aref arr (lvec->list! idx lst))) st-r of-r)) - ret)) - (make-from-list (lst) - (let* ((ret (make-dims (list-dimensions lst))) - (st-r (store ret))) - (declare (type ,tensor-class ret) - (type ,(linear-array-type (getf opt :store-type)) st-r)) - (list-loop (idx ele lst) - with (linear-sums - (of-r (strides ret) (head ret))) - do (,(getf opt :value-writer) (,(getf opt :coercer) ele) st-r of-r)) - ret))) - (let ((largs (length args))) - (if (= largs 1) - (etypecase (first args) - (array - (make-from-array (first args))) - (cons - (make-from-list (first args))) - (integer - (make-dims (list (first args))))) - (make-dims args)))))))) + (deft/generic (t/zeros #'subtypep) sym (dims &optional initial-element)) + (deft/method t/zeros (class standard-tensor) (dims &optional initial-element) + (with-gensyms (astrs adims sizs) + `(let* ((,adims (make-index-store ,dims))) + (multiple-value-bind (,astrs ,sizs) (make-stride ,adims) + (make-instance ',class + :dimensions ,adims + :head 0 + :strides ,astrs + :store (t/store-allocator ,class ,sizs ,@(when initial-element `(,initial-element)))))))) - (make-tensor-maker make-real-tensor (real-tensor)) - (make-tensor-maker make-complex-tensor (complex-tensor)) + (defgeneric zeros-generic (dims dtype) + (:documentation "Create a tensor with dimensions @arg{dims} of class @arg{dtype}.") + (:method ((dims cons) (dtype t)) + (assert (member dtype *tensor-type-leaves*) nil 'tensor-abstract-class :tensor-class dtype) + (compile-and-eval + `(defmethod zeros-generic ((dims cons) (dtype (eql ',dtype))) + (t/zeros ,dtype dims))) + (zeros-generic dims dtype))) - #+maxima - (make-tensor-maker make-symbolic-tensor (symbolic-tensor)) - - ;;Had to move it here in the wait for copy! - (definline sub-tensor (tensor subscripts &optional (preserve-rank nil)) - (copy (sub-tensor~ tensor subscripts preserve-rank))) - - ;;This seems unnecessary. - (defmacro make-zeros-dims (func-name (tensor-class)) - (let ((opt (get-tensor-class-optimization-hashtable tensor-class))) - (assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class) - `(progn - (eval-when (:compile-toplevel :load-toplevel :execute) - (let ((opt (get-tensor-class-optimization-hashtable ',tensor-class))) - (assert opt nil 'tensor-cannot-find-optimization :tensor-class ',tensor-class) - (setf (getf opt :zero-maker) ',func-name - (get-tensor-class-optimization ',tensor-class) opt))) - (defun ,func-name (dims) - (declare (type (or cons index-store-vector) dims)) - (let*-typed ((dims (if (consp dims) (make-index-store dims) (copy-seq dims)) :type index-store-vector) - (rnk (length dims) :type index-type)) - (multiple-value-bind (strides size) (make-stride dims) - (let ((*check-after-initializing?* nil)) - (make-instance (case rnk (2 ',(getf opt :matrix)) (1 ',(getf opt :vector)) (t ',tensor-class)) - :strides strides :number-of-elements - :dimensions dims :store (,(getf opt :store-allocator) size) :store-size size))))))) - - (make-zeros-dims real-typed-zeros (real-tensor)) - (make-zeros-dims complex-typed-zeros (complex-tensor)) - - #+maxima - (make-zeros-dims symbolic-typed-zeros (symbolic-tensor)) + (definline zeros (dims &optional (type 'real-tensor)) - (etypecase dims - (vector - (zeros-generic (lvec->list dims) type)) - (cons - (zeros-generic dims type)) - (fixnum - (zeros-generic (list dims) type)))) ++ (let ((*check-after-initializing?* nil)) ++ (etypecase dims ++ (vector ++ (zeros-generic (lvec->list dims) type)) ++ (cons ++ (zeros-generic dims type)) ++ (fixnum ++ (zeros-generic (list dims) type))))) commit 24def88c5b5227b29154cee9e05d88d119ceade8 Author: Akshay Srinivasan <aks...@gm...> Date: Tue Jun 18 23:18:15 2013 -0700 o This is a snapshot of the current work to make writing generic template code more manageable. diff --git a/matlisp.asd b/matlisp.asd index 09ec278..dc7a129 100644 --- a/matlisp.asd +++ b/matlisp.asd @@ -69,6 +69,8 @@ (:file "macros" :depends-on ("functions")) (:file "lvec" + :depends-on ("macros" "functions")) + (:file "template" :depends-on ("macros" "functions")))) (asdf:defsystem fortran-names @@ -104,8 +106,9 @@ :depends-on ("foreign-core") :pathname "base" :components ((:file "tweakable") + (:file "template") (:file "standard-tensor" - :depends-on ("tweakable")) + :depends-on ("tweakable" "template")) ;; (:file "loopy" :depends-on ("standard-tensor")) @@ -122,17 +125,20 @@ (:module "matlisp-classes" :pathname "classes" :depends-on ("matlisp-base") - :components ((:file "real-tensor") - (:file "complex-tensor") + :components ((:file "numeric") #+maxima (:file "symbolic-tensor") + #+nil (:file "matrix" - :depends-on ("real-tensor" "complex-tensor")))) + :depends-on ("numeric")))) (:module "matlisp-level-1" :pathname "level-1" :depends-on ("matlisp-base" "matlisp-classes" "foreign-core") :components ((:file "tensor-maker") + #+nil + ( (:file "swap") + (:file "copy" :depends-on ("tensor-maker")) (:file "realimag" @@ -144,19 +150,23 @@ (:file "axpy" :depends-on ("copy" "scal")) (:file "trans" - :depends-on ("scal" "copy")))) + :depends-on ("scal" "copy"))))) + #+nil (:module "matlisp-level-2" :pathname "level-2" :depends-on ("matlisp-base" "matlisp-classes" "foreign-core" "matlisp-level-1") :components ((:file "gemv"))) + #+nil (:module "matlisp-level-3" :pathname "level-3" :depends-on ("matlisp-base" "matlisp-classes" "foreign-core" "matlisp-level-1" "matlisp-level-2") :components ((:file "gemm"))) + #+nil (:module "matlisp-lapack" :pathname "lapack" :depends-on ("matlisp-base" "matlisp-classes" "matlisp-level-1" "matlisp-level-2" "matlisp-level-3") :components ((:file "getrf"))) + #+nil (:module "matlisp-sugar" :pathname "sugar" :depends-on ("matlisp-base" "matlisp-classes" "matlisp-level-1" "matlisp-level-2" "matlisp-level-3") diff --git a/packages.lisp b/packages.lisp index 64e09af..96949cb 100644 --- a/packages.lisp +++ b/packages.lisp @@ -63,15 +63,18 @@ #:tensor-dimension-mismatch #:tensor-store-not-consecutive #:tensor-method-does-not-exist + #:tensor-abstract-class )) (defpackage "MATLISP-UTILITIES" (:use #:common-lisp #:matlisp-conditions) (:export #:ensure-list #:id #:vectorify #:copy-n - #:zip #:zip-eq + #:ensure-args #:repsym #:findsym #:find-tag + #:zip #:zip-eq #:zipsym + #:list-eq #:setadd #:setrem #:cut-cons-chain! - #:slot-values + #:slot-values #:remmeth #:recursive-append #:unquote-args #:flatten #:format-to-string #:string+ #:linear-array-type @@ -89,6 +92,11 @@ #:inlining #:definline #:with-optimization #:quickly #:very-quickly #:slowly #:quickly-if)) + +(defpackage "MATLISP-TEMPLATE" + (:use #:common-lisp #:matlisp-utilities) + (:export #:deft/generic #:deft/method #:remt/method)) + ;;Modified version of Mark Kantrowitz' infix package. (defpackage "MATLISP-INFIX" (:use #:common-lisp #:matlisp-conditions #:matlisp-utilities) @@ -162,7 +170,7 @@ (defpackage "MATLISP" (:use #:common-lisp - #:matlisp-conditions #:matlisp-utilities #:matlisp-ffi + #:matlisp-conditions #:matlisp-utilities #:matlisp-ffi #:matlisp-template #:matlisp-blas #:matlisp-lapack #:matlisp-dfftpack #:matlisp-libmatlisp) (:export #:index-type #:index-array #:allocate-index-store #:make-index-store ;;Standard-tensor diff --git a/src/base/blas-helpers.lisp b/src/base/blas-helpers.lisp index f30164e..e34dc8b 100644 --- a/src/base/blas-helpers.lisp +++ b/src/base/blas-helpers.lisp @@ -41,7 +41,7 @@ :finally (return (aref sort-std 0)))))) (defun blas-matrix-compatible-p (matrix op) - (declare (type standard-matrix matrix)) + (declare (type standard-tensor matrix)) (let*-typed ((stds (strides matrix) :type index-store-vector) (rs (aref stds 0) :type index-type) (cs (aref stds 1) :type index-type)) @@ -103,3 +103,7 @@ (defun make-stride (dims) (ecase *default-stride-ordering* (:row-major (make-stride-rmj dims)) (:col-major (make-stride-cmj dims)))) + +(definline call-fortran? (x lb) + (declare (type standard-tensor x)) + (> (lvec-max (the index-store-vector (dimensions x))) lb)) diff --git a/src/base/generic-copy.lisp b/src/base/generic-copy.lisp index 71431fa..128d66c 100644 --- a/src/base/generic-copy.lisp +++ b/src/base/generic-copy.lisp @@ -1,6 +1,6 @@ (in-package #:matlisp) -(defgeneric copy! (from-tensor to-tensor) +(defgeneric copy! (from to) (:documentation " Syntax @@ -10,45 +10,31 @@ Purpose ======= Copies the contents of X into Y. Returns Y. - - X,Y must have the same dimensions, and - ergo the same number of elements. - - Furthermore, X may be a scalar, in which - case Y is filled with X. ") - (:method :before ((x cons) (y cons)) - (assert (= (length x) (length y)))) (:method :before ((x array) (y array)) - (assert (subtypep (array-element-type x) (array-element-type y)) - nil 'invalid-type - :given (array-element-type y) :expected (array-element-type x)) - (assert (and - (= (array-rank x) (array-rank y)) - (reduce #'(lambda (x y) (and x y)) - (mapcar #'= (array-dimensions x) (array-dimensions y)))) + (assert (list-eq (array-dimensions x) (array-dimensions y)) nil 'dimension-mismatch))) (defmethod copy! ((from cons) (to cons)) (let-rec cdr-writer ((flst from) (tlst to)) - (if (null flst) to - (progn - (rplaca tlst (car flst)) - (cdr-writer (cdr flst) (cdr tlst)))))) + (unless (or (null flst) (null tlst)) + (setf (car tlst) (car flst)) + (cdr-writer (cdr flst) (cdr tlst)))) + to) -(defmethod copy! (from (to cons)) +(defmethod copy! ((from t) (to cons)) (mapl #'(lambda (lst) (rplaca lst from)) to) to) (defmethod copy! ((from array) (to array)) (let ((lst (make-list (array-rank to)))) (mod-dotimes (idx (make-index-store (array-dimensions to))) - do (progn - (lvec->list! idx lst) - (setf (apply #'aref to lst) (apply #'aref from lst))))) + :do (progn + (lvec->list! idx lst) + (setf (apply #'aref to lst) (apply #'aref from lst))))) to) -(defmethod copy! (from (to array)) +(defmethod copy! ((from t) (to array)) (let ((lst (make-list (array-rank to)))) (mod-dotimes (idx (make-index-store (array-dimensions to))) do (progn @@ -57,6 +43,42 @@ to)) ;; +(defmethod copy! :before ((x array) (y standard-tensor)) + (assert (list-eq (array-dimensions x) (lvec->list (dimensions y))) + nil 'dimension-mismatch)) +(defmethod copy! :before ((x standard-tensor) (y array)) + (assert (list-eq (array-dimensions y) (lvec->list (dimensions x))) + nil 'dimension-mismatch)) + +(defmethod copy! ((... [truncated message content] |
From: Akshay S. <ak...@us...> - 2013-03-26 04:38:19
|
This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "matlisp". The branch, tensor has been updated via ba36a2d0877b66fc5b6b4055b9310b2e60a54186 (commit) via c213febdfa60e0b1a9a11c796911eb5b93fef90e (commit) from 23ed3d8de617ebe9a31a9df73e0b5c379de1340e (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit ba36a2d0877b66fc5b6b4055b9310b2e60a54186 Merge: c213feb 23ed3d8 Author: Akshay Srinivasan <aks...@gm...> Date: Mon Mar 25 21:31:32 2013 -0700 Merge branch 'tensor' of ssh://matlisp.git.sourceforge.net/gitroot/matlisp/matlisp into tensor Conflicts: configure.ac ----------------------------------------------------------------------- Summary of changes: hooks/post-receive -- matlisp |
From: Akshay S. <ak...@us...> - 2013-03-26 04:12:31
|
This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "matlisp". The branch, classy has been created at ea151122023fbd5d481a831645292fa3232b7b8b (commit) - Log ----------------------------------------------------------------- commit ea151122023fbd5d481a831645292fa3232b7b8b Author: Akshay Srinivasan <aks...@gm...> Date: Mon Mar 25 21:11:46 2013 -0700 Saving changes. diff --git a/matlisp.asd b/matlisp.asd index 09ec278..5b8b043 100644 --- a/matlisp.asd +++ b/matlisp.asd @@ -119,6 +119,7 @@ :depends-on ("standard-tensor" "permutation")) (:file "print" :depends-on ("standard-tensor")))) + #+nil (:module "matlisp-classes" :pathname "classes" :depends-on ("matlisp-base") @@ -128,6 +129,7 @@ (:file "symbolic-tensor") (:file "matrix" :depends-on ("real-tensor" "complex-tensor")))) + #+nil (:module "matlisp-level-1" :pathname "level-1" :depends-on ("matlisp-base" "matlisp-classes" "foreign-core") @@ -145,18 +147,22 @@ :depends-on ("copy" "scal")) (:file "trans" :depends-on ("scal" "copy")))) + #+nil (:module "matlisp-level-2" :pathname "level-2" :depends-on ("matlisp-base" "matlisp-classes" "foreign-core" "matlisp-level-1") :components ((:file "gemv"))) + #+nil (:module "matlisp-level-3" :pathname "level-3" :depends-on ("matlisp-base" "matlisp-classes" "foreign-core" "matlisp-level-1" "matlisp-level-2") :components ((:file "gemm"))) + #+nil (:module "matlisp-lapack" :pathname "lapack" :depends-on ("matlisp-base" "matlisp-classes" "matlisp-level-1" "matlisp-level-2" "matlisp-level-3") :components ((:file "getrf"))) + #+nil (:module "matlisp-sugar" :pathname "sugar" :depends-on ("matlisp-base" "matlisp-classes" "matlisp-level-1" "matlisp-level-2" "matlisp-level-3") diff --git a/src/base/standard-tensor.lisp b/src/base/standard-tensor.lisp index 5981619..5e84180 100644 --- a/src/base/standard-tensor.lisp +++ b/src/base/standard-tensor.lisp @@ -33,53 +33,36 @@ (make-index-store contents)) ;; -(defclass standard-tensor () - ((rank - :reader rank - :type index-type - :documentation "Rank of the tensor: number of arguments for the tensor") - (dimensions +(defclass tensor () + ((dimensions :reader dimensions :initarg :dimensions :type index-store-vector :documentation "Dimensions of the vector spaces in which the tensor's arguments reside.") - (number-of-elements - :reader number-of-elements - :type index-type - :documentation "Total number of elements in the tensor.") ;; (parent-tensor :reader parent-tensor :initarg :parent-tensor - :type standard-tensor + :type tensor :documentation "If the tensor is a view of another tensor, then this slot is bound.") ;; - (memos - :reader memos - :initform (make-hash-table) - :type list - :documentation "Cache for arbitrary (computable) attributes of the object.") - (head - :initarg :head - :initform 0 - :reader head - :type index-type - :documentation "Head for the store's accessor.") - (strides - :initarg :strides - :reader strides - :type index-store-vector - :documentation "Strides for accesing elements of the tensor.") - (store-size - :initarg :store-size - :reader store-size - :type index-type - :documentation "Size of the store.") (store - :initarg :store :reader store - :documentation "The actual storage for the tensor.")) - (:documentation "Basic tensor class.")) + :initarg :store) + ;; + (memos + :reader memos + :initarg :memos + :documentation "Cache for arbitrary (computable) attributes of the object."))) + +;; +(defclass dense-tensor (tensor) + ((store :type dense-store))) + +(defclass dense-store () + ((vector-store) + (head) + (strides)) ;; (defclass standard-matrix (standard-tensor) @@ -113,7 +96,7 @@ (declare (ignore initargs)) (assert (= (rank old) 1) nil 'tensor-not-vector :rank (rank old))) -;; +;;Use (defmacro defmemo (func-name (tensor) &rest body) " This macro defines a function taking a tensor argument @arg{tensor}, and memoizes the @@ -302,16 +285,16 @@ ;; (defmethod initialize-instance :after ((tensor standard-tensor) &rest initargs) (declare (ignore initargs)) - (let-typed ((dims (dimensions tensor) :type index-store-vector)) - (setf (rank tensor) (length dims)) - (when *check-after-initializing?* + (when *check-after-initializing?* + (let-typed ((dims (dimensions tensor) :type index-store-vector)) + (setf (slot-value tensor 'rank) (length dims)) (assert (>= (head tensor) 0) nil 'tensor-invalid-head-value :head (head tensor) :tensor tensor) (if (not (slot-boundp tensor 'strides)) (multiple-value-bind (stds size) (make-stride dims) (declare (type index-store-vector stds) (type index-type size)) - (setf (number-of-elements tensor) size - (strides tensor) stds) + (setf (slot-value tensor 'number-of-elements) size + (slot-value tensor 'strides) stds) (assert (<= (+ (head tensor) (1- (number-of-elements tensor))) (store-size tensor)) nil 'tensor-insufficient-store :store-size (store-size tensor) :max-idx (+ (head tensor) (1- (number-of-elements tensor))) :tensor tensor)) (very-quickly (let-typed ((stds (strides tensor) :type index-store-vector)) @@ -321,9 +304,7 @@ :do (progn (assert (> (aref stds i) 0) nil 'tensor-invalid-stride-value :argument i :stride (aref stds i) :tensor tensor) (assert (> (aref dims i) 0) nil 'tensor-invalid-dimension-value :argument i :dimension (aref dims i) :tensor tensor)) - :finally (progn - (assert (>= (the index-type (store-size tensor)) (the index-type (+ (the index-type (head tensor)) lidx))) nil 'tensor-insufficient-store :store-size (store-size tensor) :max-idx lidx :tensor tensor) - (setf (number-of-elements tensor) sz))))))))) + :finally (assert (>= (the index-type (store-size tensor)) (the index-type (+ (the index-type (head tensor)) lidx))) nil 'tensor-insufficient-store :store-size (store-size tensor) :max-idx lidx :tensor tensor)))))))) ;; (defgeneric tensor-ref (tensor &rest subscripts) @@ -360,8 +341,7 @@ (defgeneric (setf tensor-store-ref) (value tensor idx)) ;; -(defgeneric print-element (tensor - element stream) +(defgeneric print-element (tensor element stream) (:documentation " Syntax ====== diff --git a/src/ffi/c-ffi.lisp b/src/ffi/c-ffi.lisp index a7fd066..924d9db 100644 --- a/src/ffi/c-ffi.lisp +++ b/src/ffi/c-ffi.lisp @@ -2,13 +2,12 @@ (in-package #:matlisp-ffi) -(defmacro defccomplex (name base-type) - `(cffi:defcstruct ,name - (real ,base-type) - (imag ,base-type))) - -(defccomplex %c.complex-double :double) -(defccomplex %c.complex-float :float) +(macrolet ((defccomplex (name base-type) + `(cffi:defcstruct ,name + (real ,base-type) + (imag ,base-type)))) + (defccomplex %c.complex-double :double) + (defccomplex %c.complex-float :float)) ;; Get the equivalent CFFI type. ;; If the type is an array, get the type of the array element type. diff --git a/src/level-1/tensor-maker.lisp b/src/level-1/tensor-maker.lisp index 1a9ec29..700f8a5 100644 --- a/src/level-1/tensor-maker.lisp +++ b/src/level-1/tensor-maker.lisp @@ -18,6 +18,7 @@ (rnk (length vdim)) (ret (let ((*check-after-initializing?* nil)) (make-instance (case rnk (2 ',(getf opt :matrix)) (1 ',(getf opt :vector)) (t ',tensor-class)) + :rank rnk :strides (make-stride vdim) :store store :store-size ss :dimensions vdim)))) (setf (slot-value ret 'number-of-elements) ss) @@ -78,11 +79,12 @@ (defun ,func-name (dims) (declare (type (or cons index-store-vector) dims)) (let*-typed ((dims (if (consp dims) (make-index-store dims) (copy-seq dims)) :type index-store-vector) - (rnk (length dims) :type index-type) - (size (very-quickly (lvec-foldl #'(lambda (a b) (declare (type index-type a b)) (the index-type (* a b))) dims)))) - (let ((*check-after-initializing?* nil)) - (make-instance (case rnk (2 ',(getf opt :matrix)) (1 ',(getf opt :vector)) (t ',tensor-class)) - :dimensions dims :store (,(getf opt :store-allocator) size) :store-size size))))))) + (rnk (length dims) :type index-type)) + (multiple-value-bind (strides size) (make-stride dims) + (let ((*check-after-initializing?* nil)) + (make-instance (case rnk (2 ',(getf opt :matrix)) (1 ',(getf opt :vector)) (t ',tensor-class)) + :strides strides :number-of-elements + :dimensions dims :store (,(getf opt :store-allocator) size) :store-size size))))))) (make-zeros-dims real-typed-zeros (real-tensor)) (make-zeros-dims complex-typed-zeros (complex-tensor)) diff --git a/src/level-2/gemv.lisp b/src/level-2/gemv.lisp index 9307caa..4aab067 100644 --- a/src/level-2/gemv.lisp +++ b/src/level-2/gemv.lisp @@ -17,7 +17,7 @@ (declare (type ,(getf opt :element-type) alpha beta) (type ,matrix-class A) (type ,vector-class x y) - (type symbol job)) + (type list job)) ,(let ((lisp-routine `(let-typed ((nr-A (nrows A) :type index-type) @@ -31,8 +31,10 @@ (hd-x (head x) :type index-type) ; (stp-y (aref (strides y) 0) :type index-type) - (sto-y (store y) :type ,(linear-array-type (getf opt :store-type)))) - (when (eq job :t) + (sto-y (store y) :type ,(linear-array-type (getf opt :store-type))) + ; + (job (car job) :type character)) + (when (char= job #\T) (rotatef nr-A nc-A) (rotatef rs-A cs-A)) (very-quickly @@ -51,7 +53,7 @@ (if blas-gemv-func `(mlet* ((call-fortran? (> (max (nrows A) (ncols A)) ,fortran-call-lb)) - ((maj-A ld-A fop-A) (blas-matrix-compatible-p A job) :type (symbol index-type (string 1)))) + ((maj-A ld-A fop-A) (blas-matrix-compatible-p A job) :type (symbol index-type character))) (cond (call-fortran? (if maj-A commit e6de232ea94a34325a971da0355eecf472c7769c Merge: f3d0633 23ed3d8 Author: Akshay Srinivasan <aks...@gm...> Date: Sun Mar 24 13:21:45 2013 -0700 Merge branch 'tensor' from sourceforge. commit f3d0633327f4ceba538ccb2657552b6069850bfe Author: Akshay Srinivasan <aks...@gm...> Date: Sun Mar 24 13:15:13 2013 -0700 Saving changes; this breaks a lot of things. diff --git a/src/base/blas-helpers.lisp b/src/base/blas-helpers.lisp index f30164e..f48901a 100644 --- a/src/base/blas-helpers.lisp +++ b/src/base/blas-helpers.lisp @@ -1,82 +1,69 @@ (in-package #:matlisp) -;;Check dimensions of the tensors before passing the argument here! +(definline fortran-nop (op) + (ecase op (#\T #\N) (#\N #\T))) + +(defun split-job (job) + (declare (type symbol job)) + (let-typed ((name (symbol-name job) :type string)) + (loop :for x :across name :collect x))) + +(definline flip-major (job) + (declare (type symbol job)) + (case job + (:row-major :col-major) + (:col-major :row-major))) + (defun blas-copyable-p (ten-a ten-b) (declare (type standard-tensor ten-a ten-b)) - (mlet* - (((sort-std-a std-a-perm) (let-typed ((std-a (strides ten-a) :type index-store-vector)) - (very-quickly (sort-permute (copy-seq std-a) #'<))) - :type (index-store-vector permutation-action)) - (perm-a-dims (permute (dimensions ten-a) std-a-perm) :type index-store-vector) - ;;If blas-copyable then the strides must have the same sorting permutation. - (sort-std-b (permute (strides ten-b) std-a-perm) :type index-store-vector) - (perm-b-dims (permute (dimensions ten-b) std-a-perm) :type index-store-vector)) - (very-quickly - (loop - :for i :of-type index-type :from 0 :below (rank ten-a) - :for sost-a :across sort-std-a - :for a-aoff :of-type index-type := (aref sort-std-a 0) :then (the index-type (* a-aoff (aref perm-a-dims (1- i)))) - ;; - :for sost-b :across sort-std-b - :for b-aoff :of-type index-type := (aref sort-std-b 0) :then (the index-type (* b-aoff (aref perm-b-dims (1- i)))) - ;; - :do (progn - (unless (and (= sost-a a-aoff) - (= sost-b b-aoff)) - (return nil))) - :finally (return (list (aref sort-std-a 0) (aref sort-std-b 0))))))) + (when (= (rank ten-a) (rank ten-b)) + (mlet* + (((sort-std-a std-a-perm) (very-quickly (sort-permute-base (copy-seq (the index-store-vector (strides ten-a))) #'<)) :type (index-store-vector pindex-store-vector)) + (perm-a-dims (very-quickly (apply-action! (copy-seq (the index-store-vector (dimensions ten-a))) std-a-perm)) :type index-store-vector) + ;;If blas-copyable then the strides must have the same sorting permutation. + (sort-std-b (very-quickly (apply-action! (copy-seq (the index-store-vector (strides ten-b))) std-a-perm)) :type index-store-vector) + (perm-b-dims (very-quickly (apply-action! (copy-seq (the index-store-vector (dimensions ten-b))) std-a-perm)) :type index-store-vector)) + (very-quickly + (loop + :for i :of-type index-type :from 0 :below (rank ten-a) + :for sost-a :across sort-std-a + :for a-aoff :of-type index-type := (aref sort-std-a 0) :then (the index-type (* a-aoff (aref perm-a-dims (1- i)))) + ;; + :for sost-b :across sort-std-b + :for b-aoff :of-type index-type := (aref sort-std-b 0) :then (the index-type (* b-aoff (aref perm-b-dims (1- i)))) + ;; + :do (unless (and (= sost-a a-aoff) + (= sost-b b-aoff) + (= (aref perm-a-dims i) (aref perm-b-dims i))) + (return nil)) + :finally (return (list (aref sort-std-a 0) (aref sort-std-b 0)))))))) -(defun consecutive-store-p (tensor) +(defmemo consecutive-store-p (tensor) (declare (type standard-tensor tensor)) - (mlet* (((sort-std std-perm) (let-typed ((stds (strides tensor) :type index-store-vector)) - (very-quickly (sort-permute (copy-seq stds) #'<))) - :type (index-store-vector permutation)) - (perm-dims (permute (dimensions tensor) std-perm) :type index-store-vector)) - (very-quickly - (loop - :for so-st :across sort-std - :for so-di :across perm-dims - :and accumulated-off := (aref sort-std 0) :then (the index-type (* accumulated-off so-di)) - :unless (= so-st accumulated-off) :do (return nil) - :finally (return (aref sort-std 0)))))) + (mlet* (((sort-std std-perm) (very-quickly (sort-permute-base (copy-seq (the index-store-vector (strides tensor))) #'<)) + :type (index-store-vector pindex-store-vector)) + (perm-dims (very-quickly (apply-action! (copy-seq (the index-store-vector (dimensions tensor))) std-perm)) :type index-store-vector)) + (very-quickly + (loop + :for so-st :across sort-std + :for so-di :across perm-dims + :and accumulated-off := (aref sort-std 0) :then (the index-type (* accumulated-off so-di)) + :unless (= so-st accumulated-off) :do (return nil) + + :finally (return (values t (aref sort-std 0))))))) -(defun blas-matrix-compatible-p (matrix op) - (declare (type standard-matrix matrix)) +(definline blas-matrix-compatible-p (matrix op) + (declare (type standard-matrix matrix) + (type character op)) (let*-typed ((stds (strides matrix) :type index-store-vector) (rs (aref stds 0) :type index-type) (cs (aref stds 1) :type index-type)) ;;Note that it is not required that (rs = nc * cs) or (cs = nr * rs) (cond ((= cs 1) (values :row-major rs (fortran-nop op))) - ((= rs 1) (values :col-major cs (fortran-op op))) - (t (values nil 0 "?"))))) - -(definline fortran-op (op) - (ecase op (:n "N") (:t "T"))) - -(definline fortran-nop (op) - (ecase op (:t "N") (:n "T"))) - -(defun fortran-snop (sop) - (cond - ((string= sop "N") "T") - ((string= sop "T") "N") - (t (error "Unrecognised fortran-op.")))) - -(defun split-job (job) - (values-list - (map 'list #'(lambda (x) (intern (string x) "KEYWORD")) (symbol-name job)))) - -(defun combine-jobs (&rest jobs) - (let ((job (intern (apply #'concatenate 'string (mapcar #'symbol-name jobs)) "KEYWORD"))) - job)) - -(definline flip-major (job) - (declare (type symbol job)) - (case job - (:row-major :col-major) - (:col-major :row-major))) + ((= rs 1) (values :col-major cs op))))) +;;Stride makers. (definline make-stride-rmj (dims) (declare (type index-store-vector dims)) (let-typed ((stds (allocate-index-store (length dims)) :type index-store-vector)) diff --git a/src/base/permutation.lisp b/src/base/permutation.lisp index fd45591..db544ff 100644 --- a/src/base/permutation.lisp +++ b/src/base/permutation.lisp @@ -289,7 +289,7 @@ (make-instance 'permutation-action :store (very-quickly (apply-flips! ret idiv))))) ;;Uber-functional stuff -;;None of these are ever useful (I've found), neat things for showing off though :] +;;None of these are ever useful (I've found); neat things for showing off though :] (defun permute-arguments-and-compile (func perm) (declare (type function func) (type permutation perm)) diff --git a/src/base/standard-tensor.lisp b/src/base/standard-tensor.lisp index a5840e1..5981619 100644 --- a/src/base/standard-tensor.lisp +++ b/src/base/standard-tensor.lisp @@ -35,53 +35,56 @@ ;; (defclass standard-tensor () ((rank - :accessor rank + :reader rank :type index-type :documentation "Rank of the tensor: number of arguments for the tensor") (dimensions - :accessor dimensions + :reader dimensions :initarg :dimensions :type index-store-vector :documentation "Dimensions of the vector spaces in which the tensor's arguments reside.") (number-of-elements - :accessor number-of-elements + :reader number-of-elements :type index-type :documentation "Total number of elements in the tensor.") ;; (parent-tensor - :accessor parent-tensor + :reader parent-tensor :initarg :parent-tensor :type standard-tensor :documentation "If the tensor is a view of another tensor, then this slot is bound.") ;; + (memos + :reader memos + :initform (make-hash-table) + :type list + :documentation "Cache for arbitrary (computable) attributes of the object.") (head :initarg :head :initform 0 - :accessor head + :reader head :type index-type :documentation "Head for the store's accessor.") (strides :initarg :strides - :accessor strides + :reader strides :type index-store-vector :documentation "Strides for accesing elements of the tensor.") (store-size :initarg :store-size - :accessor store-size + :reader store-size :type index-type :documentation "Size of the store.") (store :initarg :store - :accessor store + :reader store :documentation "The actual storage for the tensor.")) (:documentation "Basic tensor class.")) ;; (defclass standard-matrix (standard-tensor) ((rank - :accessor rank :allocation :class - :type index-type :initform 2 :documentation "For a matrix, rank = 2.")) (:documentation "Basic matrix class.")) @@ -97,9 +100,7 @@ ;; (defclass standard-vector (standard-tensor) ((rank - :accessor rank :allocation :class - :type index-type :initform 1 :documentation "For a vector, rank = 1.")) (:documentation "Basic vector class.")) @@ -113,6 +114,39 @@ (assert (= (rank old) 1) nil 'tensor-not-vector :rank (rank old))) ;; +(defmacro defmemo (func-name (tensor) &rest body) + " + This macro defines a function taking a tensor argument @arg{tensor}, and memoizes the + results of the code @arg{body}. It is assumed that the function definition is functional + in character. + + Examples: + @lisp + > (macroexpand-1 `(defmemo thing (x) (+ x (rank x)))) + > (defun thing (x) + (declare (type standard-tensor x)) + (let ((memo-hash (memos x))) + (multiple-value-bind (value present?) (gethash 'thing memo-hash) + (if present? value + (let ((value (progn (+ x (rank x))))) + (setf (gethash 'thing memo-hash) value) + value))))) + T + > + @end lisp +" + (let ((decls (when (and (consp (car body)) (eql (caar body) 'declare)) (cdar body)))) + `(defun ,func-name (,tensor) + (declare (type standard-tensor ,tensor) + ,@decls) + (let* ((memo-hash (memos ,tensor))) + (multiple-value-bind (value present?) (gethash ',func-name memo-hash) + (if present? (values-list value) + (let ((value (multiple-value-list (progn ,@(if decls (cdr body) body))))) + (values-list (setf (gethash ',func-name memo-hash) value))))))))) + + +;; (defvar *tensor-class-optimizations* (make-hash-table) " Contains a either: diff --git a/src/level-1/tensor-maker.lisp b/src/level-1/tensor-maker.lisp index 1620666..2f13d0d 100644 --- a/src/level-1/tensor-maker.lisp +++ b/src/level-1/tensor-maker.lisp @@ -20,7 +20,7 @@ (make-instance (case rnk (2 ',(getf opt :matrix)) (1 ',(getf opt :vector)) (t ',tensor-class)) :strides (make-stride vdim) :store store :store-size ss :dimensions vdim)))) - (setf (number-of-elements ret) ss) + (setf (slot-value ret 'number-of-elements) ss) ret)) (make-from-array (arr) (declare (type (array * *) arr)) diff --git a/src/utilities/functions.lisp b/src/utilities/functions.lisp index aefe273..4a618ec 100644 --- a/src/utilities/functions.lisp +++ b/src/utilities/functions.lisp @@ -3,39 +3,39 @@ ;;These functions are used all over the place inside Matlisp's macros. (eval-when (:compile-toplevel :load-toplevel :execute) - (declaim (inline id)) - (defun id (x) x) +(declaim (inline id)) +(defun id (x) x) - (declaim (inline vectorify)) - (defun vectorify (seq n &optional (element-type t)) - (declare (type (or vector list) seq)) - (etypecase seq - (cons - (let ((ret (make-array n :element-type element-type))) - (loop :for i :of-type fixnum :from 0 :below n - :for lst := seq :then (cdr lst) - :do (setf (aref ret i) (car lst)) - :finally (return ret)))) - (vector - (let ((ret (make-array n :element-type element-type))) - (loop :for i :of-type fixnum :from 0 :below n - :for ele :across seq - :do (setf (aref ret i) ele) - :finally (return ret)))))) +(declaim (inline vectorify)) +(defun vectorify (seq n &optional (element-type t)) + (declare (type (or vector list) seq)) + (etypecase seq + (cons + (let ((ret (make-array n :element-type element-type))) + (loop :for i :of-type fixnum :from 0 :below n + :for lst := seq :then (cdr lst) + :do (setf (aref ret i) (car lst)) + :finally (return ret)))) + (vector + (let ((ret (make-array n :element-type element-type))) + (loop :for i :of-type fixnum :from 0 :below n + :for ele :across seq + :do (setf (aref ret i) ele) + :finally (return ret)))))) - (declaim (inline copy-n)) - (defun copy-n (vec lst n) - (declare (type vector vec) - (type list lst) - (type fixnum n)) - (loop :for i :of-type fixnum :from 0 :below n - :for vlst := lst :then (cdr vlst) - :do (setf (car vlst) (aref vec i))) - lst) - - (declaim (inline slot-values)) - (defun slot-values (obj slots) - " +(declaim (inline copy-n)) +(defun copy-n (vec lst n) + (declare (type vector vec) + (type list lst) + (type fixnum n)) + (loop :for i :of-type fixnum :from 0 :below n + :for vlst := lst :then (cdr vlst) + :do (setf (car vlst) (aref vec i))) + lst) + +(declaim (inline slot-values)) +(defun slot-values (obj slots) + " Returns the slots of the @arg{obj} corresponding to symbols in the list @arg{slots}. Example: @@ -48,13 +48,13 @@ => 1 2 @end lisp " - (values-list - (loop :for slt :in slots - :collect (slot-value obj slt)))) + (values-list + (loop :for slt :in slots + :collect (slot-value obj slt)))) - (declaim (inline linear-array-type)) - (defun linear-array-type (type-sym &optional (size '*)) - " +(declaim (inline linear-array-type)) +(defun linear-array-type (type-sym &optional (size '*)) + " Creates the list representing simple-array with type @arg{type-sym}. Example: @@ -63,11 +63,11 @@ => (simple-array double-float (10)) @end lisp " - `(simple-array ,type-sym (,size))) + `(simple-array ,type-sym (,size))) - (declaim (inline ensure-list)) - (defun ensure-list (lst) - " +(declaim (inline ensure-list)) +(defun ensure-list (lst) + " Ensconses @arg{lst} inside a list if it is an atom. Example: @@ -76,10 +76,10 @@ => (a) @end lisp " - (if (listp lst) lst `(,lst))) + (if (listp lst) lst `(,lst))) - (defun cut-cons-chain! (lst test) - " +(defun cut-cons-chain! (lst test) + " Destructively cuts @arg{lst} into two parts, at the element where the function @arg{test} returns a non-nil value. @@ -90,20 +90,20 @@ => (3 5) (3 5) (2 1 7 9) @end lisp " - (declare (type list lst)) - (labels ((cut-cons-chain-tin (lst test parent-lst) - (cond - ((null lst) nil) - ((funcall test (cadr lst)) - (let ((keys (cdr lst))) - (setf (cdr lst) nil) - (values parent-lst keys))) - (t (cut-cons-chain-tin (cdr lst) test parent-lst))))) - (cut-cons-chain-tin lst test lst))) + (declare (type list lst)) + (labels ((cut-cons-chain-tin (lst test parent-lst) + (cond + ((null lst) nil) + ((funcall test (cadr lst)) + (let ((keys (cdr lst))) + (setf (cdr lst) nil) + (values parent-lst keys))) + (t (cut-cons-chain-tin (cdr lst) test parent-lst))))) + (cut-cons-chain-tin lst test lst))) - (declaim (inline zip)) - (defun zip (&rest args) - " +(declaim (inline zip)) +(defun zip (&rest args) + " Zips the elements of @arg{args}. Example: @@ -112,10 +112,10 @@ => ((2 A J) (3 B H) (4 C C)) @end lisp " - (apply #'map 'list #'list args)) + (apply #'map 'list #'list args)) - (defun recursive-append (&rest lsts) - " +(defun recursive-append (&rest lsts) + " Appends lists in a nested manner, mostly used to bring in the charm of non-lispy languages into macros. @@ -162,15 +162,15 @@ X) @end lisp " - (labels ((bin-append (x y) - (if (null x) - (if (typep (car y) 'symbol) y (car y)) - (append x (if (null y) nil - (if (typep (car y) 'symbol) `(,y) y)))))) - (reduce #'bin-append lsts :from-end t))) + (labels ((bin-append (x y) + (if (null x) + (if (typep (car y) 'symbol) y (car y)) + (append x (if (null y) nil + (if (typep (car y) 'symbol) `(,y) y)))))) + (reduce #'bin-append lsts :from-end t))) - (defun unquote-args (lst args) - " +(defun unquote-args (lst args) + " Makes a list suitable for use inside macros (sort-of), by building a new list quoting every symbol in @arg{lst} other than those in @arg{args}. CAUTION: DO NOT use backquotes! @@ -184,34 +184,34 @@ => (LIST 'LET (LIST (LIST X '1)) (LIST '+ X '1)) @end lisp " - (labels ((replace-atoms (lst ret) - (cond - ((null lst) (reverse ret)) - ((atom lst) - (let ((ret (reverse ret))) - (rplacd (last ret) lst) - ret)) - ((consp lst) - (replace-atoms (cdr lst) (let ((fst (car lst))) - (cond - ((atom fst) - (if (member fst args) - (cons fst ret) - (append `(',fst) ret))) - ((consp fst) - (cons (replace-lst fst nil) ret)))))))) - (replace-lst (lst acc) - (cond - ((null lst) acc) - ((consp lst) - (if (eq (car lst) 'quote) - lst - (cons 'list (replace-atoms lst nil)))) - ((atom lst) lst)))) - (replace-lst lst nil))) + (labels ((replace-atoms (lst ret) + (cond + ((null lst) (reverse ret)) + ((atom lst) + (let ((ret (reverse ret))) + (rplacd (last ret) lst) + ret)) + ((consp lst) + (replace-atoms (cdr lst) (let ((fst (car lst))) + (cond + ((atom fst) + (if (member fst args) + (cons fst ret) + (append `(',fst) ret))) + ((consp fst) + (cons (replace-lst fst nil) ret)))))))) + (replace-lst (lst acc) + (cond + ((null lst) acc) + ((consp lst) + (if (eq (car lst) 'quote) + lst + (cons 'list (replace-atoms lst nil)))) + ((atom lst) lst)))) + (replace-lst lst nil))) - (defun flatten (x) - " +(defun flatten (x) + " Returns a new list by collecting all the symbols found in @arg{x}. Borrowed from Onlisp. @@ -221,16 +221,16 @@ => (LET X 1 + X 2) @end lisp " - (labels ((rec (x acc) - (cond ((null x) acc) - ((atom x) (cons x acc)) - (t (rec - (car x) - (rec (cdr x) acc)))))) - (rec x nil))) + (labels ((rec (x acc) + (cond ((null x) acc) + ((atom x) (cons x acc)) + (t (rec + (car x) + (rec (cdr x) acc)))))) + (rec x nil))) - (defun list-dimensions (lst) - " +(defun list-dimensions (lst) + " Returns the dimensions of the nested list @arg{lst}, by finding the length of the immediate list, recursively. This does not ensure the uniformity of lengths of the lists. @@ -241,21 +241,21 @@ => (2 3) @end lisp " - (declare (type list lst)) - (labels ((lst-tread (idx lst) - (if (null lst) (reverse idx) - (progn - (setf (car idx) (length lst)) - (if (consp (car lst)) - (lst-tread (cons 0 idx) (car lst)) - (reverse idx)))))) - (lst-tread (list 0) lst))) + (declare (type list lst)) + (labels ((lst-tread (idx lst) + (if (null lst) (reverse idx) + (progn + (setf (car idx) (length lst)) + (if (consp (car lst)) + (lst-tread (cons 0 idx) (car lst)) + (reverse idx)))))) + (lst-tread (list 0) lst))) - (defun compile-and-eval (source) - " +(defun compile-and-eval (source) + " Compiles and evaluates the given @arg{source}. This should be an ANSI compatible way of ensuring method compilation." - (funcall (compile nil `(lambda () ,source)))) + (funcall (compile nil `(lambda () ,source)))) - ) +) commit 9f01a9f4f148c9a00ad80d5eacffd667db2cbbb7 Author: Akshay Srinivasan <aks...@gm...> Date: Fri Mar 22 10:13:51 2013 -0700 Added a inline method for applying permutations (encoded as its action), useful in blas-helpers. diff --git a/src/base/permutation.lisp b/src/base/permutation.lisp index f3e2b93..fd45591 100644 --- a/src/base/permutation.lisp +++ b/src/base/permutation.lisp @@ -115,6 +115,15 @@ (permute! (copy thing) perm arg)) ;;Action +(definline apply-action! (seq perm) + (declare (type vector seq) + (type pindex-store-vector perm)) + (let* ((size (length perm)) + (cseq (vectorify seq size))) + (loop :for i :from 0 :below size + :do (setf (aref seq i) (aref cseq (aref perm i))) + :finally (return seq)))) + (defmethod permute! ((seq cons) (perm permutation-action) &optional arg) (declare (ignore arg)) (let* ((size (permutation-size perm)) @@ -127,12 +136,7 @@ (defmethod permute! ((seq vector) (perm permutation-action) &optional arg) (declare (ignore arg)) - (let* ((size (permutation-size perm)) - (cseq (vectorify seq size)) - (act (store perm))) - (loop :for i :from 0 :below size - :do (setf (aref seq i) (aref cseq (aref act i))) - :finally (return seq)))) + (apply-action! seq (the pindex-store-vector (store perm)))) (defmethod permute! ((ten standard-tensor) (perm permutation-action) &optional (arg 0)) (permute! ten (action->pivot-flip perm) arg)) commit 83545ebc9021cad75969d41c803f5a4557c61e9a Author: Akshay Srinivasan <aks...@gm...> Date: Fri Mar 22 10:10:23 2013 -0700 Added a new sort function which does not return a permutation class on return. diff --git a/src/base/permutation.lisp b/src/base/permutation.lisp index 778ceba..f3e2b93 100644 --- a/src/base/permutation.lisp +++ b/src/base/permutation.lisp @@ -334,7 +334,7 @@ ;;Back to practical matters. ;;This function is ugly of-course, but is also very very quick! -(definline sort-permute (seq predicate &key (key #'matlisp-utilities:id)) +(definline sort-permute-base (seq predicate &key (key #'matlisp-utilities:id)) " Sorts a lisp-vector in-place, by using the function @arg{predicate} as the order. Also computes the permutation action which would sort the original @@ -393,4 +393,8 @@ (decf piv) (decf ubound) nil))))) - :finally (return (values seq (make-instance 'permutation-action :store perm)))))) + :finally (return (values seq perm))))) + +(definline sort-permute (seq predicate &key (key #'matlisp-utilities:id)) + (multiple-value-bind (seq perm) (sort-permute-base seq predicate :key key) + (values seq (make-instance 'permutation-action :store perm)))) ----------------------------------------------------------------------- hooks/post-receive -- matlisp |
From: Akshay S. <ak...@us...> - 2013-03-24 20:23:28
|
This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "matlisp". The branch, tensor has been updated via 23ed3d8de617ebe9a31a9df73e0b5c379de1340e (commit) from 8d1294ce927280b8f2633b1e8636bd8aacfbf45d (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 23ed3d8de617ebe9a31a9df73e0b5c379de1340e Author: Akshay Srinivasan <aks...@gm...> Date: Sun Mar 24 13:23:02 2013 -0700 Made make-zeros-dims intialize classes without checking. diff --git a/lib-src/gnuplot/gnuplot.lisp b/lib-src/gnuplot/gnuplot.lisp index 4894a43..9bfaf56 100644 --- a/lib-src/gnuplot/gnuplot.lisp +++ b/lib-src/gnuplot/gnuplot.lisp @@ -25,11 +25,11 @@ (defun gnuplot-send (str) (unless *current-gnuplot-process* (setf *current-gnuplot-process* (open-gnuplot-stream))) - (let (stream (#+:sbcl - sb-ext:process-input + (let ((stream (#+:sbcl + sb-ext:process-input #+:ccl ccl:external-process-input-stream - *current-gnuplot-process*)) + *current-gnuplot-process*))) (format stream "~a~%" str) (finish-output stream))) diff --git a/src/level-1/tensor-maker.lisp b/src/level-1/tensor-maker.lisp index 1620666..1ba6fc1 100644 --- a/src/level-1/tensor-maker.lisp +++ b/src/level-1/tensor-maker.lisp @@ -65,6 +65,7 @@ (definline sub-tensor (tensor subscripts &optional (preserve-rank nil)) (copy (sub-tensor~ tensor subscripts preserve-rank))) +;;This seems unnecessary. (defmacro make-zeros-dims (func-name (tensor-class)) (let ((opt (get-tensor-class-optimization-hashtable tensor-class))) (assert opt nil 'tensor-cannot-find-optimization :tensor-class tensor-class) @@ -79,11 +80,12 @@ (let*-typed ((dims (if (consp dims) (make-index-store dims) (copy-seq dims)) :type index-store-vector) (rnk (length dims) :type index-type) (size (very-quickly (lvec-foldl #'(lambda (a b) (declare (type index-type a b)) (the index-type (* a b))) dims)))) - (make-instance (case rnk (2 ',(getf opt :matrix)) (1 ',(getf opt :vector)) (t ',tensor-class)) - :dimensions dims :store (,(getf opt :store-allocator) size) :store-size size)))))) + (let ((*check-after-initializing?* nil)) + (make-instance (case rnk (2 ',(getf opt :matrix)) (1 ',(getf opt :vector)) (t ',tensor-class)) + :dimensions dims :store (,(getf opt :store-allocator) size) :store-size size))))))) (make-zeros-dims real-typed-zeros (real-tensor)) (make-zeros-dims complex-typed-zeros (complex-tensor)) #+maxima -(make-zeros-dims symbolc-typed-tensor (symbolic-tensor)) +(make-zeros-dims symbolic-typed-zeros (symbolic-tensor)) ----------------------------------------------------------------------- Summary of changes: lib-src/gnuplot/gnuplot.lisp | 6 +++--- src/level-1/tensor-maker.lisp | 8 +++++--- 2 files changed, 8 insertions(+), 6 deletions(-) hooks/post-receive -- matlisp |